more modularityand modified shortcuts
This commit is contained in:
demattia
parent
c41e53c747
commit
06ef0c8a1f
|
|
@ -0,0 +1,382 @@
|
|||
;;This addition provides a directory-tree-browsing-functionality.
|
||||
;;This means:
|
||||
;;When using it you hand over a list of strings, that shall be
|
||||
;;interpreted as paths and a string that represents the path, relative to
|
||||
;;which the path-list is given.
|
||||
;;In the result-window of the NUIT a file-browsing screen is shown
|
||||
;;which you can browse in using arrow-keys and enter. You can also
|
||||
;;select some items and paste them into the upper window.
|
||||
|
||||
;;If there are paths to files handed over that do not exist, they will not be
|
||||
;;displayed in the browser!
|
||||
|
||||
;;If the given path does not exist you will not be able to navigate!
|
||||
|
||||
|
||||
(define-record-type browse-dir-list-res-obj browse-dir-list-res-obj
|
||||
(make-browse-dir-list-res-obj pos-y
|
||||
pos-x
|
||||
file-list
|
||||
result-text
|
||||
working-directory
|
||||
width
|
||||
initial-wd
|
||||
marked-items
|
||||
res-marked-items
|
||||
c-x-pressed)
|
||||
browse-dir-list-res-obj?
|
||||
(pos-y browse-dir-list-res-obj-pos-y)
|
||||
(pos-x browse-dir-list-res-obj-pos-x)
|
||||
(file-list browse-dir-list-res-obj-file-list)
|
||||
(result-text browse-dir-list-res-obj-result-text)
|
||||
(working-directory browse-dir-list-res-obj-working-directory)
|
||||
(width browse-dir-list-res-obj-width)
|
||||
(initial-wd browse-dir-list-res-obj-initial-wd)
|
||||
(marked-items browse-dir-list-res-obj-marked-items)
|
||||
(res-marked-items browse-dir-list-res-obj-res-marked-items)
|
||||
(c-x-pressed browse-dir-list-res-obj-c-x-pressed))
|
||||
|
||||
|
||||
;;Layout of the directory-tree-browser
|
||||
(define layout-result-browse-dir-list
|
||||
(lambda (result-str result width directory)
|
||||
(begin
|
||||
(let ((printed-file-list (print-file-list-1 result directory))
|
||||
(heading ""))
|
||||
(begin
|
||||
(if (<= (string-length directory) (- width 25))
|
||||
(set! heading (string-append "Paths relative to "
|
||||
directory " :"))
|
||||
(let ((dir-string (substring directory
|
||||
(- (string-length directory)
|
||||
(- width 25))
|
||||
(string-length directory))))
|
||||
(set! heading (string-append "Paths relative to ..."
|
||||
dir-string))))
|
||||
(append (list heading) (list " <-") printed-file-list))))))
|
||||
|
||||
|
||||
;;One File per-line
|
||||
;;In case the object is a directory "/" is added
|
||||
(define print-file-list-1
|
||||
(lambda (file-list dir)
|
||||
(let loop ((old file-list)
|
||||
(new '()))
|
||||
(if (equal? '() old)
|
||||
new
|
||||
(let* ((hd (list-ref old 0))
|
||||
(hd-path (string-append dir "/" hd))
|
||||
(tl (cdr old)))
|
||||
(if (file-exists? hd-path)
|
||||
(if (file-directory? hd-path)
|
||||
(let ((new-str (string-append " " hd "/")))
|
||||
(loop tl (append new (list new-str))))
|
||||
(loop tl (append new (list (string-append " " hd)))))
|
||||
(loop tl new)))))))
|
||||
|
||||
;;selection->descend
|
||||
(define selected-browse-dir-list
|
||||
(lambda (model)
|
||||
(let ((ln (browse-dir-list-res-obj-pos-y model))
|
||||
(wd (browse-dir-list-res-obj-working-directory model)))
|
||||
(if (not (file-exists? wd))
|
||||
model
|
||||
(begin (chdir wd)
|
||||
(if (or (>= ln (+ (length
|
||||
(browse-dir-list-res-obj-result-text model)) 1))
|
||||
(<= ln 1))
|
||||
model
|
||||
(if (= ln 2)
|
||||
(if (not (equal? "/" (cwd)))
|
||||
(begin
|
||||
(chdir "..")
|
||||
(let* ((new-result (evaluate "(directory-files)"))
|
||||
(new-result-string (exp->string new-result))
|
||||
(width (browse-dir-list-res-obj-width model))
|
||||
(new-text (layout-result-browse-dir-list
|
||||
new-result-string
|
||||
new-result width (cwd)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
(browse-dir-list-res-obj-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-c-x-pressed
|
||||
model))))
|
||||
new-model))
|
||||
model)
|
||||
(let* ((text (browse-dir-list-res-obj-result-text model))
|
||||
(ent (list-ref text (- ln 1)))
|
||||
(len (string-length ent))
|
||||
(last-char (substring ent (- len 1) len))
|
||||
(rest (substring ent 1 (- len 1))))
|
||||
(if (equal? last-char "/")
|
||||
(begin
|
||||
(chdir wd)
|
||||
(chdir rest)
|
||||
(let* ((new-result (evaluate "(directory-files)"))
|
||||
(new-result-string (exp->string new-result))
|
||||
(width (browse-dir-list-res-obj-width model))
|
||||
(new-text (layout-result-browse-dir-list
|
||||
new-result-string new-result width
|
||||
(cwd)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
(browse-dir-list-res-obj-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-c-x-pressed model))))
|
||||
new-model))
|
||||
model)))))))))
|
||||
|
||||
(define browse-dir-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) 2)
|
||||
(begin
|
||||
(set! result (list "forgot parameters?"))
|
||||
(let* ((text
|
||||
(layout-result-standard "forgot parameters?"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-dir-list-res-obj 1 1 result text (cwd)
|
||||
width (cwd) '() '() #f)))
|
||||
browse-obj))
|
||||
|
||||
(let* ((file-list
|
||||
(evaluate (list-ref parameters 0)))
|
||||
(dir (evaluate (list-ref parameters 1)))
|
||||
(result-string (exp->string file-list))
|
||||
(width (next-command-message-width message))
|
||||
(text
|
||||
(layout-result-browse-dir-list result-string
|
||||
file-list width dir))
|
||||
(browse-obj
|
||||
(make-browse-dir-list-res-obj 2 1 file-list text dir width
|
||||
(cwd) '() '() #f)))
|
||||
browse-obj))))
|
||||
|
||||
((print-message? message)
|
||||
(let* ((model (print-message-object message))
|
||||
(pos-y (browse-dir-list-res-obj-pos-y model))
|
||||
(pos-x (browse-dir-list-res-obj-pos-x model))
|
||||
(text (browse-dir-list-res-obj-result-text model))
|
||||
(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)))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (key-pressed-message-result-model message))
|
||||
(key (key-pressed-message-key message))
|
||||
(c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
|
||||
|
||||
(if c-x-pressed
|
||||
(cond
|
||||
;;Ctrl+x s -> Auswahl
|
||||
((= key 115)
|
||||
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
||||
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
||||
model))
|
||||
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
||||
(all-items (browse-dir-list-res-obj-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item #f))
|
||||
(begin
|
||||
(if (not (equal? (cwd) "/"))
|
||||
(set! actual-res-item (string-append (cwd) "/" actual-item))
|
||||
(set! actual-res-item (string-append "/" actual-item)))
|
||||
(if (member actual-res-item marked-items)
|
||||
model
|
||||
(let* ((new-res-marked-items (append res-marked-items
|
||||
(list
|
||||
actual-res-item)))
|
||||
(new-marked-items (append marked-items
|
||||
(list actual-item)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list
|
||||
model)
|
||||
(browse-dir-list-res-obj-result-text
|
||||
model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items
|
||||
#f)))
|
||||
new-model)))))))
|
||||
|
||||
;;Ctrl+x u -> unselect
|
||||
((= key 117)
|
||||
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
||||
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
||||
model))
|
||||
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
||||
(all-items (browse-dir-list-res-obj-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item (string-append (cwd) "/" actual-item))
|
||||
(rest (member actual-item marked-items))
|
||||
(res-rest (member actual-res-item res-marked-items)))
|
||||
(if (not res-rest)
|
||||
model
|
||||
(let* ((after-item (length rest))
|
||||
(all-items (length marked-items))
|
||||
(before-item (sublist marked-items
|
||||
0
|
||||
(- all-items
|
||||
after-item )))
|
||||
(new-marked-items (append before-item
|
||||
(list-tail rest 1)))
|
||||
(after-res-item (length res-rest))
|
||||
(all-res-items (length res-marked-items))
|
||||
(before-res-item (sublist res-marked-items
|
||||
0
|
||||
(- all-res-items
|
||||
after-res-item)))
|
||||
(new-res-marked-items (append before-res-item
|
||||
(list-tail res-rest
|
||||
1)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list
|
||||
model)
|
||||
(browse-dir-list-res-obj-result-text
|
||||
model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items
|
||||
#f)))
|
||||
new-model))))))
|
||||
(else
|
||||
(make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(not c-x-pressed))))
|
||||
|
||||
(cond
|
||||
;;c-x
|
||||
((= key 24)
|
||||
(make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(not c-x-pressed)))
|
||||
|
||||
((= key key-up)
|
||||
(let ((posy (browse-dir-list-res-obj-pos-y model)))
|
||||
(if (<= posy 2)
|
||||
model
|
||||
(let* ((new-posy (- posy 1))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
new-posy
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
#f)))
|
||||
new-model))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((posy (browse-dir-list-res-obj-pos-y model))
|
||||
(num-lines (length
|
||||
(browse-dir-list-res-obj-result-text model))))
|
||||
(if (>= posy num-lines)
|
||||
model
|
||||
(let* ((new-posy (+ posy 1))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
new-posy
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
#f)))
|
||||
new-model))))
|
||||
|
||||
((= key 10)
|
||||
(selected-browse-dir-list model))
|
||||
|
||||
|
||||
|
||||
(else model)))))
|
||||
|
||||
|
||||
((restore-message? message)
|
||||
(let* ((model (restore-message-object message))
|
||||
(initial-wd (browse-dir-list-res-obj-initial-wd model)))
|
||||
(chdir initial-wd)))
|
||||
|
||||
((selection-message? message)
|
||||
(let* ((model (selection-message-object message))
|
||||
(marked-items (browse-dir-list-res-obj-res-marked-items model)))
|
||||
(string-append "'" (exp->string marked-items)))))))
|
||||
|
||||
(define browse-dir-list-rec (make-receiver "browse-dir-list"
|
||||
browse-dir-list-receiver))
|
||||
|
||||
(set! receivers (cons browse-dir-list-rec receivers))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,345 @@
|
|||
;;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))
|
||||
243
scheme/cd.scm
243
scheme/cd.scm
|
|
@ -1,193 +1,84 @@
|
|||
;;cd
|
||||
;;This command can be used on all platforms because it uses the
|
||||
;;scsh-Function "chdir"
|
||||
|
||||
(define-record-type cd-result-object cd-result-object
|
||||
(make-cd-result-object pos-y
|
||||
pos-x
|
||||
file-list
|
||||
result-text
|
||||
working-directory
|
||||
width
|
||||
initial-wd
|
||||
marked-items
|
||||
res-marked-items)
|
||||
cd-result-object?
|
||||
(pos-y cd-result-object-pos-y)
|
||||
(pos-x cd-result-object-pos-x)
|
||||
(file-list cd-result-object-file-list)
|
||||
(result-text cd-result-object-result-text)
|
||||
(working-directory cd-result-object-working-directory)
|
||||
(width cd-result-object-width)
|
||||
(initial-wd cd-result-object-initial-wd)
|
||||
(marked-items cd-result-object-marked-items)
|
||||
(res-marked-items cd-result-object-res-marked-items))
|
||||
|
||||
;;Layout of the result of cd
|
||||
(define layout-result-cd
|
||||
(lambda (result-str result width)
|
||||
(begin
|
||||
(let ((printed-file-list (print-file-list result))
|
||||
(directory (cwd))
|
||||
(heading ""))
|
||||
(begin
|
||||
(if (<= (string-length directory) (- width 27))
|
||||
(set! heading (string-append "Directory-Content of "
|
||||
directory " :"))
|
||||
(let ((dir-string (substring directory
|
||||
(- (string-length directory)
|
||||
(- width 27))
|
||||
(string-length directory))))
|
||||
(set! heading (string-append "Directory-Content of ..."
|
||||
dir-string))))
|
||||
(append (list heading) printed-file-list))))))
|
||||
|
||||
;;One File per-line
|
||||
;;In case the object is a directory "/" is added
|
||||
(define print-file-list
|
||||
(lambda (file-list)
|
||||
(let loop ((old file-list)
|
||||
(new '()))
|
||||
(if (equal? '() old)
|
||||
new
|
||||
(let ((hd (list-ref old 0))
|
||||
(tl (cdr old)))
|
||||
(if (file-directory? hd)
|
||||
(let ((new-str (string-append " " hd "/")))
|
||||
(loop tl (append new (list new-str))))
|
||||
(loop tl (append new (list (string-append " " hd))))))))))
|
||||
|
||||
;;selection->descend
|
||||
(define selected-cd
|
||||
(lambda (model)
|
||||
(let ((ln (cd-result-object-pos-y model))
|
||||
(wd (cd-result-object-working-directory model)))
|
||||
(begin
|
||||
(chdir wd)
|
||||
(if (or (>= ln (+ (length (cd-result-object-result-text model)) 1))
|
||||
(<= ln 1))
|
||||
model
|
||||
(let* ((text (cd-result-object-result-text model))
|
||||
(ent (list-ref text (- ln 1)))
|
||||
(len (string-length ent))
|
||||
(last-char (substring ent (- len 1) len))
|
||||
(rest (substring ent 1 (- len 1))))
|
||||
(if (equal? last-char "/")
|
||||
(begin
|
||||
(chdir rest)
|
||||
(let* ((new-result (evaluate "(directory-files)"))
|
||||
(new-result-string (exp->string new-result))
|
||||
(width (cd-result-object-width model))
|
||||
(new-text (layout-result-cd
|
||||
new-result-string new-result width))
|
||||
(new-model (make-cd-result-object
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(cd-result-object-initial-wd model)
|
||||
(cd-result-object-marked-items model)
|
||||
(cd-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))
|
||||
model)))))))
|
||||
;;cd-res-objects are only warppers around browse-directoty-list-res-objects.
|
||||
;;They only differ in the restore-procedure:
|
||||
;;Other "directory-browsing-commands" like find or ls restore the old working-directory,
|
||||
;;the directory that was valid, when they were initially called. cd changes the
|
||||
;;current-working-directory permanently.
|
||||
|
||||
|
||||
(define-record-type cd-res-obj cd-res-obj
|
||||
(make-cd-res-obj browse-obj)
|
||||
cd-res-obj?
|
||||
(browse-obj cd-res-obj-browse-obj))
|
||||
|
||||
(define cd-receiver
|
||||
(lambda (message)
|
||||
(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)))
|
||||
|
||||
(begin
|
||||
(if (null? parameters)
|
||||
(begin
|
||||
(set! result (list "forgot parameters?"))
|
||||
(let* ((text
|
||||
(layout-result-standard "forgot parameters?"
|
||||
result width))
|
||||
(std-obj
|
||||
(make-cd-result-object 1 1 result text (cwd) width
|
||||
(cwd) '() '())))
|
||||
std-obj))
|
||||
|
||||
(begin
|
||||
(evaluate (string-append "(chdir "
|
||||
(exp->string (car parameters))
|
||||
" )"))
|
||||
(set! result (evaluate "(directory-files)"))
|
||||
(let* ((result-string (exp->string result))
|
||||
(width (next-command-message-width message))
|
||||
(text
|
||||
(layout-result-cd result-string result width))
|
||||
(cd-obj
|
||||
(make-cd-result-object 2 1 result text (cwd) width
|
||||
(cwd) '() '())))
|
||||
cd-obj))))))
|
||||
(let* ((width (next-command-message-width message))
|
||||
(parameters (next-command-message-parameters message)))
|
||||
(if (null? parameters)
|
||||
(let* ((result (list "Forgot path!"))
|
||||
(text
|
||||
(layout-result-standard "Forgot Path!"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-dir-list-res-obj 1 1 result text (cwd)
|
||||
width (cwd) '() '() #f)))
|
||||
(make-cd-res-obj browse-obj))
|
||||
(let ((path (car parameters)))
|
||||
(if (not (file-exists? path))
|
||||
(let* ((result (list "Path doesn't exist"))
|
||||
(text
|
||||
(layout-result-standard "Path doesn't exist!"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-dir-list-res-obj 1 1 result text (cwd)
|
||||
width (cwd) '() '() #f)))
|
||||
(make-cd-res-obj browse-obj))
|
||||
(begin
|
||||
(chdir path)
|
||||
(let* ((browse-next-command-message
|
||||
(make-next-command-message "browse-dir-list"
|
||||
'("(directory-files)" "(cwd)")
|
||||
width)))
|
||||
(make-cd-res-obj (browse-dir-list-receiver
|
||||
browse-next-command-message)))))))))
|
||||
((print-message? message)
|
||||
(let* ((model (print-message-object message))
|
||||
(pos-y (cd-result-object-pos-y model))
|
||||
(pos-x (cd-result-object-pos-x model))
|
||||
(text (cd-result-object-result-text model))
|
||||
(marked-pos (get-marked-positions-2
|
||||
(cd-result-object-file-list model)
|
||||
(cd-result-object-marked-items model))))
|
||||
(make-print-object pos-y pos-x text (list pos-y) marked-pos)))
|
||||
(width (print-message-width message))
|
||||
(browser (cd-res-obj-browse-obj model))
|
||||
(browse-print-message
|
||||
(make-print-message "browse-dir-list"
|
||||
browser
|
||||
width)))
|
||||
(browse-dir-list-receiver browse-print-message)))
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (key-pressed-message-result-model message))
|
||||
(key (key-pressed-message-key message)))
|
||||
(cond
|
||||
((= key key-up)
|
||||
(let ((posy (cd-result-object-pos-y model)))
|
||||
(if (<= posy 2)
|
||||
model
|
||||
(let* ((new-posy (- posy 1))
|
||||
(new-model (make-cd-result-object
|
||||
new-posy
|
||||
(cd-result-object-pos-x model)
|
||||
(cd-result-object-file-list model)
|
||||
(cd-result-object-result-text model)
|
||||
(cd-result-object-working-directory model)
|
||||
(cd-result-object-width model)
|
||||
(cd-result-object-initial-wd model)
|
||||
(cd-result-object-marked-items model)
|
||||
(cd-result-object-res-marked-items model))))
|
||||
new-model))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((posy (cd-result-object-pos-y model))
|
||||
(num-lines (length
|
||||
(cd-result-object-result-text model))))
|
||||
(if (>= posy num-lines)
|
||||
model
|
||||
(let* ((new-posy (+ posy 1))
|
||||
(new-model (make-cd-result-object
|
||||
new-posy
|
||||
(cd-result-object-pos-x model)
|
||||
(cd-result-object-file-list model)
|
||||
(cd-result-object-result-text model)
|
||||
(cd-result-object-working-directory model)
|
||||
(cd-result-object-width model)
|
||||
(cd-result-object-initial-wd model)
|
||||
(cd-result-object-marked-items model)
|
||||
(cd-result-object-res-marked-items model))))
|
||||
new-model))))
|
||||
|
||||
((= key 10)
|
||||
(selected-cd model))
|
||||
(else model))))
|
||||
|
||||
|
||||
(key (key-pressed-message-key message))
|
||||
(browser (cd-res-obj-browse-obj model))
|
||||
(browse-key-message
|
||||
(make-key-pressed-message "browse-dir-list"
|
||||
browser
|
||||
key)))
|
||||
(make-cd-res-obj (browse-dir-list-receiver
|
||||
browse-key-message))))
|
||||
|
||||
((restore-message? message)
|
||||
values)
|
||||
(let* ((model (restore-message-object message))
|
||||
(browser (cd-res-obj-browse-obj model))
|
||||
(wd (browse-dir-list-res-obj-working-directory browser)))
|
||||
(chdir wd)))
|
||||
((selection-message? message)
|
||||
""))))
|
||||
|
||||
(let* ((model (selection-message-object message))
|
||||
(browser (cd-res-obj-browse-obj model))
|
||||
(browse-sel-message
|
||||
(make-selection-message "browse-dir-list"
|
||||
browser)))
|
||||
(browse-dir-list-receiver browse-sel-message)))
|
||||
)))
|
||||
|
||||
(define cd-rec (make-receiver "cd" cd-receiver))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,315 +1,66 @@
|
|||
|
||||
;;directory-files
|
||||
;;---------------
|
||||
|
||||
|
||||
(define initial-working-directory (cwd))
|
||||
|
||||
;;Result-Object für "directory-files"
|
||||
(define-record-type dirfiles-result-object dirfiles-result-object
|
||||
(make-dirfiles-result-object pos-y
|
||||
pos-x
|
||||
file-list
|
||||
result-text
|
||||
working-directory
|
||||
width
|
||||
initial-wd
|
||||
marked-items
|
||||
res-marked-items)
|
||||
dirfiles-result-object?
|
||||
(pos-y dirfiles-result-object-pos-y)
|
||||
(pos-x dirfiles-result-object-pos-x)
|
||||
(file-list dirfiles-result-object-file-list)
|
||||
(result-text dirfiles-result-object-result-text)
|
||||
(working-directory dirfiles-result-object-working-directory)
|
||||
(width dirfiles-result-object-width)
|
||||
(initial-wd dirfiles-result-object-initial-wd)
|
||||
(marked-items dirfiles-result-object-marked-items)
|
||||
(res-marked-items dirfiles-result-object-res-marked-items))
|
||||
|
||||
;;Darstellung, falls die Eingabe ist: "(directory-files)"
|
||||
(define layout-result-dirfiles
|
||||
(lambda (result-str result width)
|
||||
(begin
|
||||
(let ((printed-file-list (print-file-list result))
|
||||
(directory (cwd))
|
||||
(heading ""))
|
||||
(begin
|
||||
(if (<= (string-length directory) (- width 27))
|
||||
(set! heading (string-append "Directory-Content of "
|
||||
directory " :"))
|
||||
(let ((dir-string (substring directory
|
||||
(- (string-length directory)
|
||||
(- width 27))
|
||||
(string-length directory))))
|
||||
(set! heading (string-append "Directory-Content of ..."
|
||||
dir-string))))
|
||||
(append (list heading) (list " <-")
|
||||
printed-file-list))))))
|
||||
;;Basically the result-object of this command is only a wrapper for a
|
||||
;;"browse-dir-list"-object. The messages are simply handed over
|
||||
|
||||
|
||||
;;Eine Datei pro Zeile
|
||||
;;Falls es sich um ein Verzeichnis handelt wird "/" hinzugefügt
|
||||
(define print-file-list
|
||||
(lambda (file-list)
|
||||
(let loop ((old file-list)
|
||||
(new '()))
|
||||
(if (equal? '() old)
|
||||
new
|
||||
(let ((hd (list-ref old 0))
|
||||
(tl (cdr old)))
|
||||
(if (file-directory? hd)
|
||||
(let ((new-str (string-append " " hd "/")))
|
||||
(loop tl (append new (list new-str))))
|
||||
(loop tl (append new (list (string-append " " hd))))))))))
|
||||
|
||||
;;Auswahl->absteigen
|
||||
(define selected-dirfiles
|
||||
(lambda (model)
|
||||
(let ((ln (dirfiles-result-object-pos-y model))
|
||||
(wd (dirfiles-result-object-working-directory model)))
|
||||
(begin (chdir wd)
|
||||
(if (or (>= ln (+ (length
|
||||
(dirfiles-result-object-result-text model)) 1))
|
||||
(<= ln 1))
|
||||
model
|
||||
(if (= ln 2)
|
||||
(if (not (equal? "/" (cwd)))
|
||||
(begin
|
||||
(chdir "..")
|
||||
(let* ((new-result (evaluate "(directory-files)"))
|
||||
(new-result-string (exp->string new-result))
|
||||
(width (dirfiles-result-object-width model))
|
||||
(new-text (layout-result-dirfiles
|
||||
new-result-string
|
||||
new-result width))
|
||||
(new-model (make-dirfiles-result-object
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(dirfiles-result-object-initial-wd
|
||||
model)
|
||||
(dirfiles-result-object-marked-items
|
||||
model)
|
||||
(dirfiles-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))
|
||||
model)
|
||||
(let* ((text (dirfiles-result-object-result-text model))
|
||||
(ent (list-ref text (- ln 1)))
|
||||
(len (string-length ent))
|
||||
(last-char (substring ent (- len 1) len))
|
||||
(rest (substring ent 1 (- len 1))))
|
||||
(if (equal? last-char "/")
|
||||
(begin
|
||||
(chdir rest)
|
||||
(let* ((new-result (evaluate "(directory-files)"))
|
||||
(new-result-string (exp->string new-result))
|
||||
(width (dirfiles-result-object-width model))
|
||||
(new-text (layout-result-dirfiles
|
||||
new-result-string new-result width))
|
||||
(new-model (make-dirfiles-result-object
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(dirfiles-result-object-initial-wd
|
||||
model)
|
||||
(dirfiles-result-object-marked-items
|
||||
model)
|
||||
(dirfiles-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))
|
||||
model))))))))
|
||||
(define-record-type dirfiles-res-obj dirfiles-res-obj
|
||||
(make-dirfiles-res-obj browse-obj)
|
||||
dirfiles-res-obj?
|
||||
(browse-obj dirfiles-res-obj-browse-obj))
|
||||
|
||||
|
||||
|
||||
|
||||
;;Receiver für directory-files
|
||||
(define dir-files-receiver
|
||||
(lambda (message)
|
||||
(cond
|
||||
|
||||
(lambda (message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(let* ((command (next-command-string message))
|
||||
(result (evaluate "(directory-files)"))
|
||||
(result-string (exp->string result))
|
||||
(width (next-command-message-width message))
|
||||
(text (layout-result-dirfiles result-string result width))
|
||||
(model (make-dirfiles-result-object 2 1 result text (cwd)
|
||||
width (cwd) '() '())))
|
||||
model))
|
||||
|
||||
(let* ((width (next-command-message-width message))
|
||||
(browse-next-command-message
|
||||
(make-next-command-message "browse-dir-list"
|
||||
'("(directory-files)" "(cwd)")
|
||||
width)))
|
||||
|
||||
(make-dirfiles-res-obj (browse-dir-list-receiver
|
||||
browse-next-command-message))))
|
||||
((print-message? message)
|
||||
(let* ((model (print-message-object message))
|
||||
(posy (dirfiles-result-object-pos-y model))
|
||||
(posx (dirfiles-result-object-pos-x model))
|
||||
(text (dirfiles-result-object-result-text model))
|
||||
(marked-pos (get-marked-positions-3
|
||||
(dirfiles-result-object-file-list model)
|
||||
(dirfiles-result-object-marked-items model))))
|
||||
(make-print-object posy posx text (list posy) marked-pos)))
|
||||
|
||||
(width (print-message-width message))
|
||||
(browser (dirfiles-res-obj-browse-obj model))
|
||||
(browse-print-message
|
||||
(make-print-message "browse-dir-list"
|
||||
browser
|
||||
width)))
|
||||
(browse-dir-list-receiver browse-print-message)))
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (key-pressed-message-result-model message))
|
||||
(key (key-pressed-message-key message)))
|
||||
(cond
|
||||
|
||||
((= key key-up)
|
||||
(let ((posy (dirfiles-result-object-pos-y model)))
|
||||
(if (<= posy 2)
|
||||
model
|
||||
(let* ((new-posy (- posy 1))
|
||||
(new-model (make-dirfiles-result-object
|
||||
new-posy
|
||||
(dirfiles-result-object-pos-x model)
|
||||
(dirfiles-result-object-file-list model)
|
||||
(dirfiles-result-object-result-text
|
||||
model)
|
||||
(dirfiles-result-object-working-directory
|
||||
model)
|
||||
(dirfiles-result-object-width model)
|
||||
(dirfiles-result-object-initial-wd model)
|
||||
(dirfiles-result-object-marked-items
|
||||
model)
|
||||
(dirfiles-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((posy (dirfiles-result-object-pos-y model))
|
||||
(num-lines (length
|
||||
(dirfiles-result-object-result-text model))))
|
||||
(if (>= posy num-lines)
|
||||
model
|
||||
(let* ((new-posy (+ posy 1))
|
||||
(new-model (make-dirfiles-result-object
|
||||
new-posy
|
||||
(dirfiles-result-object-pos-x model)
|
||||
(dirfiles-result-object-file-list model)
|
||||
(dirfiles-result-object-result-text
|
||||
model)
|
||||
(dirfiles-result-object-working-directory
|
||||
model)
|
||||
(dirfiles-result-object-width model)
|
||||
(dirfiles-result-object-initial-wd
|
||||
model)
|
||||
(dirfiles-result-object-marked-items
|
||||
model)
|
||||
(dirfiles-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))))
|
||||
|
||||
((= key 10)
|
||||
(selected-dirfiles model))
|
||||
|
||||
;;Ctrl+s -> Auswahl
|
||||
((= key 19)
|
||||
(let* ((marked-items (dirfiles-result-object-marked-items model))
|
||||
(res-marked-items (dirfiles-result-object-res-marked-items
|
||||
model))
|
||||
(actual-pos (dirfiles-result-object-pos-y model))
|
||||
(all-items (dirfiles-result-object-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item #f))
|
||||
(begin
|
||||
(if (not (equal? (cwd) "/"))
|
||||
(set! actual-res-item (string-append (cwd) "/" actual-item))
|
||||
(set! actual-res-item (string-append "/" actual-item)))
|
||||
(if (member actual-res-item marked-items)
|
||||
model
|
||||
(let* ((new-res-marked-items (append res-marked-items
|
||||
(list
|
||||
actual-res-item)))
|
||||
(new-marked-items (append marked-items
|
||||
(list actual-item)))
|
||||
(new-model (make-dirfiles-result-object
|
||||
(dirfiles-result-object-pos-y model)
|
||||
(dirfiles-result-object-pos-x model)
|
||||
(dirfiles-result-object-file-list
|
||||
model)
|
||||
(dirfiles-result-object-result-text
|
||||
model)
|
||||
(dirfiles-result-object-working-directory
|
||||
model)
|
||||
(dirfiles-result-object-width model)
|
||||
(dirfiles-result-object-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items)))
|
||||
new-model)))))))
|
||||
|
||||
;;Ctrl+u -> aus Auswahl rausnehmen
|
||||
((= key 21)
|
||||
(let* ((marked-items (dirfiles-result-object-marked-items model))
|
||||
(res-marked-items (dirfiles-result-object-res-marked-items
|
||||
model))
|
||||
(actual-pos (dirfiles-result-object-pos-y model))
|
||||
(all-items (dirfiles-result-object-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item (string-append (cwd) "/" actual-item))
|
||||
(rest (member actual-item marked-items))
|
||||
(res-rest (member actual-res-item res-marked-items)))
|
||||
(if (not res-rest)
|
||||
model
|
||||
(let* ((after-item (length rest))
|
||||
(all-items (length marked-items))
|
||||
(before-item (sublist marked-items
|
||||
0
|
||||
(- all-items
|
||||
after-item )))
|
||||
(new-marked-items (append before-item
|
||||
(list-tail rest 1)))
|
||||
(after-res-item (length res-rest))
|
||||
(all-res-items (length res-marked-items))
|
||||
(before-res-item (sublist res-marked-items
|
||||
0
|
||||
(- all-res-items
|
||||
after-res-item)))
|
||||
(new-res-marked-items (append before-res-item
|
||||
(list-tail res-rest
|
||||
1)))
|
||||
(new-model (make-dirfiles-result-object
|
||||
(dirfiles-result-object-pos-y model)
|
||||
(dirfiles-result-object-pos-x model)
|
||||
(dirfiles-result-object-file-list
|
||||
model)
|
||||
(dirfiles-result-object-result-text
|
||||
model)
|
||||
(dirfiles-result-object-working-directory
|
||||
model)
|
||||
(dirfiles-result-object-width model)
|
||||
(dirfiles-result-object-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items)))
|
||||
new-model))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(else model))))
|
||||
|
||||
(key (key-pressed-message-key message))
|
||||
(browser (dirfiles-res-obj-browse-obj model))
|
||||
(browse-key-message
|
||||
(make-key-pressed-message "browse-dir-list"
|
||||
browser
|
||||
key)))
|
||||
(make-dirfiles-res-obj (browse-dir-list-receiver
|
||||
browse-key-message))))
|
||||
|
||||
((restore-message? message)
|
||||
;(let ((model (restore-message-object message)))
|
||||
;(chdir (dirfiles-result-object-initial-wd model))))
|
||||
(chdir initial-working-directory))
|
||||
|
||||
(let* ((model (restore-message-object message))
|
||||
(browser (dirfiles-res-obj-browse-obj model))
|
||||
(browse-restore-message
|
||||
(make-restore-message "browse-dir-list"
|
||||
browser)))
|
||||
(browse-dir-list-receiver browse-restore-message)))
|
||||
((selection-message? message)
|
||||
(let* ((model (selection-message-object message))
|
||||
(marked-items (dirfiles-result-object-res-marked-items model)))
|
||||
(string-append "'" (exp->string marked-items))))
|
||||
|
||||
|
||||
|
||||
(else values))))
|
||||
(browser (dirfiles-res-obj-browse-obj model))
|
||||
(browse-sel-message
|
||||
(make-selection-message "browse-dir-list"
|
||||
browser)))
|
||||
(browse-dir-list-receiver browse-sel-message)))
|
||||
)))
|
||||
|
||||
|
||||
|
||||
(define dir-files-rec1
|
||||
|
|
|
|||
236
scheme/find.scm
236
scheme/find.scm
|
|
@ -1,184 +1,92 @@
|
|||
;;find
|
||||
;;This extension uses the unix-tool "find". You can only use this command in
|
||||
;;if "find" is present in your environment.
|
||||
;;This addition uses the capabilities defined in browse-directory-list
|
||||
|
||||
|
||||
;;Datatype for the representation of a find-object
|
||||
(define-record-type find-result-object find-result-object
|
||||
(make-find-result-object pos-y
|
||||
pos-x
|
||||
file-list
|
||||
result-text
|
||||
parameters
|
||||
width
|
||||
marked-items
|
||||
res-marked-items)
|
||||
find-result-object?
|
||||
(pos-y find-res-obj-pos-y)
|
||||
(pos-x find-res-obj-pos-x)
|
||||
(file-list find-res-obj-file-list)
|
||||
(result-text find-res-obj-result-text)
|
||||
(parameters find-res-obj-parameters)
|
||||
(width find-res-obj-width)
|
||||
(marked-items find-res-obj-marked-items)
|
||||
(res-marked-items find-res-obj-res-marked-items))
|
||||
|
||||
|
||||
;;Layout for Command "find"
|
||||
(define layout-result-find
|
||||
(lambda (result-str result width parameters)
|
||||
(begin
|
||||
(let ((heading ""))
|
||||
(begin
|
||||
(set! result-str (map (lambda (s) (string-append " " s)) result-str))
|
||||
(if (<= (string-length parameters) (- width 10))
|
||||
(set! heading (string-append "find "
|
||||
parameters " :"))
|
||||
(let ((dir-string (substring parameters
|
||||
(- (string-length parameters)
|
||||
(- width 10))
|
||||
(string-length parameters))))
|
||||
(set! heading (string-append "find" dir-string "..."))))
|
||||
(append (list heading) result-str))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-record-type find-res-obj find-res-obj
|
||||
(make-find-res-obj browse-obj)
|
||||
find-res-obj?
|
||||
(browse-obj find-res-obj-browse-obj))
|
||||
|
||||
|
||||
|
||||
(define find-receiver
|
||||
(lambda (message)
|
||||
(lambda (message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(let* ((command (next-command-string message))
|
||||
(parameter (next-command-message-parameters message))
|
||||
(parameters (get-param-as-str parameter))
|
||||
(result (evaluate
|
||||
(string-append "(run/sexps (find" parameters "))")))
|
||||
(result-string (map exp->string result))
|
||||
(width (next-command-message-width message)))
|
||||
(let* ((text
|
||||
(layout-result-find result-string result width parameters))
|
||||
(find-obj
|
||||
(make-find-result-object 2 1 result text parameter width
|
||||
'() '())))
|
||||
find-obj)))
|
||||
|
||||
(let* ((width (next-command-message-width message))
|
||||
(parameter (next-command-message-parameters message)))
|
||||
|
||||
(if (null? parameter)
|
||||
(let* ((result (list "Forgot parameters!"))
|
||||
(text
|
||||
(layout-result-standard "Forgot parameters!"
|
||||
result width))
|
||||
(browse-obj
|
||||
(make-browse-list-res-obj 1 1 1 1 result text
|
||||
width '() '() #f)))
|
||||
(make-find-res-obj browse-obj))
|
||||
|
||||
(let*
|
||||
((parameters (get-param-as-str parameter))
|
||||
(result (evaluate
|
||||
(string-append "(run/sexps (find" parameters "))")))
|
||||
(result-string (map exp->string result))
|
||||
(list-str (string-append "'" (exp->string result-string)))
|
||||
(browse-next-command-message
|
||||
(make-next-command-message "browse-list"
|
||||
(cons list-str
|
||||
(list "\"/\""))
|
||||
width)))
|
||||
|
||||
(make-find-res-obj (browse-list-receiver
|
||||
browse-next-command-message))))))
|
||||
((print-message? message)
|
||||
(let* ((model (print-message-object message))
|
||||
(pos-y (find-res-obj-pos-y model))
|
||||
(pos-x (find-res-obj-pos-x model))
|
||||
(text (find-res-obj-result-text model))
|
||||
(marked-pos (get-marked-positions-2
|
||||
(find-res-obj-file-list model)
|
||||
(find-res-obj-marked-items model))))
|
||||
(make-print-object pos-y pos-x text (list pos-y) marked-pos)))
|
||||
|
||||
(width (print-message-width message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-print-message
|
||||
(make-print-message "browse-list"
|
||||
browser
|
||||
width)))
|
||||
(browse-list-receiver browse-print-message)))
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (key-pressed-message-result-model message))
|
||||
(key (key-pressed-message-key message)))
|
||||
(cond
|
||||
|
||||
((= key key-up)
|
||||
(let ((posy (find-res-obj-pos-y model)))
|
||||
(if (<= posy 2)
|
||||
model
|
||||
(let* ((new-posy (- posy 1))
|
||||
(new-model (make-find-result-object
|
||||
new-posy
|
||||
(find-res-obj-pos-x model)
|
||||
(find-res-obj-file-list model)
|
||||
(find-res-obj-result-text model)
|
||||
(find-res-obj-parameters model)
|
||||
(find-res-obj-width model)
|
||||
(find-res-obj-marked-items model)
|
||||
(find-res-obj-res-marked-items model))))
|
||||
new-model))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((posy (find-res-obj-pos-y model))
|
||||
(num-lines (length
|
||||
(find-res-obj-result-text model))))
|
||||
(if (>= posy num-lines)
|
||||
model
|
||||
(let* ((new-posy (+ posy 1))
|
||||
(new-model (make-find-result-object
|
||||
new-posy
|
||||
(find-res-obj-pos-x model)
|
||||
(find-res-obj-file-list model)
|
||||
(find-res-obj-result-text model)
|
||||
(find-res-obj-parameters model)
|
||||
(find-res-obj-width model)
|
||||
(find-res-obj-marked-items model)
|
||||
(find-res-obj-res-marked-items model))))
|
||||
new-model))))
|
||||
|
||||
;;Ctrl+s -> select
|
||||
((= key 19)
|
||||
(let* ((marked-items (find-res-obj-marked-items model))
|
||||
(res-marked-items (find-res-obj-res-marked-items
|
||||
model))
|
||||
(actual-pos (find-res-obj-pos-y model))
|
||||
(all-items (find-res-obj-file-list model)))
|
||||
(if (<= actual-pos 1)
|
||||
model
|
||||
(let ((actual-item (list-ref all-items (- actual-pos 2)))
|
||||
(actual-res-item #f))
|
||||
(begin
|
||||
(if (member actual-res-item marked-items)
|
||||
model
|
||||
(let* ((new-res-marked-items (append res-marked-items
|
||||
(list
|
||||
actual-res-item)))
|
||||
(new-marked-items (append marked-items
|
||||
(list actual-item)))
|
||||
(new-model (make-find-result-object
|
||||
(find-res-obj-pos-y model)
|
||||
(find-res-obj-pos-x model)
|
||||
(find-res-obj-file-list model)
|
||||
(find-res-obj-result-text model)
|
||||
(find-res-obj-parameters model)
|
||||
(find-res-obj-width model)
|
||||
new-marked-items
|
||||
new-res-marked-items)))
|
||||
new-model)))))))
|
||||
|
||||
;;Ctrl+u -> unselect
|
||||
((= key 21)
|
||||
(let* ((marked-items (find-res-obj-marked-items model))
|
||||
(actual-pos (find-res-obj-pos-y model))
|
||||
(all-items (find-res-obj-file-list model)))
|
||||
(if (<= actual-pos 1)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 2)))
|
||||
(rest (member actual-item marked-items)))
|
||||
(if (not rest)
|
||||
model
|
||||
(let* ((after-item (length rest))
|
||||
(all-items (length marked-items))
|
||||
(before-item (sublist marked-items
|
||||
0
|
||||
(- all-items
|
||||
after-item )))
|
||||
(new-marked-items (append before-item
|
||||
(list-tail rest 1)))
|
||||
(new-model (make-find-result-object
|
||||
(find-res-obj-pos-y model)
|
||||
(find-res-obj-pos-x model)
|
||||
(find-res-obj-file-list model)
|
||||
(find-res-obj-result-text model)
|
||||
(find-res-obj-parameters model)
|
||||
(find-res-obj-width model)
|
||||
new-marked-items
|
||||
'())))
|
||||
new-model))))))
|
||||
(else model))))
|
||||
|
||||
(key (key-pressed-message-key message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-key-message
|
||||
(make-key-pressed-message "browse-list"
|
||||
browser
|
||||
key)))
|
||||
(make-find-res-obj (browse-list-receiver
|
||||
browse-key-message))))
|
||||
|
||||
((restore-message? message)
|
||||
values)
|
||||
(let* ((model (restore-message-object message))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-restore-message
|
||||
(make-restore-message "browse-ist"
|
||||
browser)))
|
||||
(browse-list-receiver browse-restore-message)))
|
||||
((selection-message? message)
|
||||
(let* ((model (selection-message-object message))
|
||||
(marked-items (find-res-obj-marked-items model)))
|
||||
(string-append "'" (exp->string
|
||||
(map exp->string marked-items))))))))
|
||||
(browser (find-res-obj-browse-obj model))
|
||||
(browse-sel-message
|
||||
(make-selection-message "browse-list"
|
||||
browser)))
|
||||
(browse-list-receiver browse-sel-message)))
|
||||
)))
|
||||
|
||||
|
||||
(define slash-away
|
||||
(lambda (path)
|
||||
(if (> (string-length path) 0)
|
||||
(substring path 1 (string-length path))
|
||||
path)))
|
||||
|
||||
|
||||
(define find-rec (make-receiver "find" find-receiver))
|
||||
|
||||
|
|
|
|||
|
|
@ -22,15 +22,16 @@
|
|||
|
||||
(define shortcuts '("F1:Exit"
|
||||
"F2:Repaint (after change of buffer size)"
|
||||
"Ctrl+d:Switch Buffer"
|
||||
"Ctrl+s:Insert/Select"
|
||||
"Ctrl+u:-/Unselect"
|
||||
"Ctrl+p:Result-History->prev"
|
||||
"Ctrl+n:Result-History->next"
|
||||
"Ctrl+x o:Switch Buffer"
|
||||
"Ctrl+x s:Insert/Select"
|
||||
"Ctrl+x u:-/Unselect"
|
||||
"Ctrl+x p:Result-History->prev"
|
||||
"Ctrl+x n:Result-History->next"
|
||||
"Ctrl+f:Command-History->forward"
|
||||
"Ctrl+b:Command-History->back"
|
||||
"Ctrl+a:First Pos"
|
||||
"Ctrl+e:End"))
|
||||
"Ctrl+a:First Pos of Line"
|
||||
"Ctrl+e:End of Line"
|
||||
"Ctrl+k:Delete Line"))
|
||||
|
||||
|
||||
|
||||
|
|
@ -138,6 +139,10 @@
|
|||
;;If a keyboard-interrupt occurs this can be checked by looking-up this box
|
||||
(define active-keyboard-interrupt #f)
|
||||
|
||||
;;This indicates if the last input was Ctrl-x
|
||||
(define c-x-pressed #f)
|
||||
|
||||
|
||||
;;Message-Types
|
||||
;;---------------------
|
||||
;;A new command was entered
|
||||
|
|
@ -262,95 +267,152 @@
|
|||
(endwin)
|
||||
(run))
|
||||
|
||||
;;Ctrl+f -> switch buffer
|
||||
((= ch 4)
|
||||
;;Ctrl-x -> wait for next input
|
||||
((= ch 24)
|
||||
(begin
|
||||
(if (= active-buffer 1)
|
||||
(set! active-buffer 2)
|
||||
(set! active-buffer 1))
|
||||
(set! c-x-pressed (not c-x-pressed))
|
||||
(if (= active-buffer 2)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(set! current-result-object (switch key-message))))
|
||||
(loop (paint))))
|
||||
|
||||
|
||||
;;if lower window is active a message is sent.
|
||||
;;if lower window is active a message is sent.
|
||||
(else
|
||||
(if (= active-buffer 2)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(begin
|
||||
(set! current-result-object (switch key-message))
|
||||
(loop (paint))))
|
||||
|
||||
(if c-x-pressed
|
||||
(cond
|
||||
|
||||
;;Enter
|
||||
((= ch 10)
|
||||
;;Ctrl-x o ->switch buffer
|
||||
((= ch 111)
|
||||
(begin
|
||||
(execute-command)
|
||||
(set! command-history-pos (- (length text-command) 1))
|
||||
;(loop (paint))))
|
||||
(endwin)
|
||||
(run)))
|
||||
|
||||
|
||||
|
||||
;;Ctrl+p -> History back
|
||||
((= ch 16)
|
||||
(begin
|
||||
(history-back)
|
||||
(if (= active-buffer 1)
|
||||
(begin
|
||||
(set! active-buffer 2)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
97)))
|
||||
(set! current-result-object (switch key-message))))
|
||||
(set! active-buffer 1))
|
||||
(set! c-x-pressed #f)
|
||||
(loop (paint))))
|
||||
|
||||
;;Ctrl+n -> History forward
|
||||
((= ch 14)
|
||||
(begin
|
||||
(history-forward)
|
||||
(loop (paint))))
|
||||
;;C-x p -> result-history back
|
||||
((= ch 112)
|
||||
(begin
|
||||
(history-back)
|
||||
(set! c-x-pressed #f)
|
||||
(loop (paint))))
|
||||
|
||||
;;Ctrl+s -> get selection
|
||||
((= ch 19)
|
||||
(let* ((message (make-selection-message active-command
|
||||
current-result-object))
|
||||
(marked-items (switch message)))
|
||||
(begin
|
||||
(add-string-to-command-buffer marked-items)
|
||||
(loop (paint)))))
|
||||
;;C-x n -> result-history forward
|
||||
((= ch 110)
|
||||
(begin
|
||||
(history-forward)
|
||||
(set! c-x-pressed #f)
|
||||
(loop (paint))))
|
||||
|
||||
(else
|
||||
(begin
|
||||
(set! command-buffer (make-buffer text-command
|
||||
pos-command
|
||||
pos-command-col
|
||||
pos-command-fin-ln
|
||||
command-buffer-pos-y
|
||||
command-buffer-pos-x
|
||||
command-lines
|
||||
command-cols
|
||||
can-write-command
|
||||
command-history-pos))
|
||||
(set! command-buffer (input command-buffer ch))
|
||||
(let ((text (buffer-text command-buffer))
|
||||
(pos-line (buffer-pos-line command-buffer))
|
||||
(pos-col (buffer-pos-col command-buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln command-buffer))
|
||||
(pos-y (buffer-pos-y command-buffer))
|
||||
(pos-x (buffer-pos-x command-buffer))
|
||||
(num-lines (buffer-num-lines command-buffer))
|
||||
(num-cols (buffer-num-cols command-buffer))
|
||||
(can-write (buffer-can-write command-buffer))
|
||||
(history-pos (buffer-history-pos command-buffer)))
|
||||
(begin
|
||||
(set! text-command text)
|
||||
(set! pos-command pos-line)
|
||||
(set! pos-command-col pos-col)
|
||||
(set! pos-command-fin-ln pos-fin-ln)
|
||||
(set! command-buffer-pos-y pos-y)
|
||||
(set! command-buffer-pos-x pos-x)
|
||||
(set! command-lines num-lines)
|
||||
(set! command-cols num-cols)
|
||||
(set! can-write-command can-write)
|
||||
(set! command-history-pos history-pos)))
|
||||
(loop (paint))))))))))))
|
||||
(else
|
||||
(begin
|
||||
(if (= active-buffer 2)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(set! current-result-object (switch key-message)))
|
||||
|
||||
(if (= ch 115)
|
||||
(let* ((message
|
||||
(make-selection-message
|
||||
active-command current-result-object))
|
||||
(marked-items (switch message)))
|
||||
(add-string-to-command-buffer marked-items))))
|
||||
(set! c-x-pressed #f)
|
||||
(loop (paint)))))
|
||||
|
||||
(if (= active-buffer 2)
|
||||
(let ((key-message
|
||||
(make-key-pressed-message active-command
|
||||
current-result-object
|
||||
ch)))
|
||||
(begin
|
||||
(set! current-result-object (switch key-message))
|
||||
(loop (paint))))
|
||||
|
||||
(cond
|
||||
|
||||
;;Enter
|
||||
((= ch 10)
|
||||
(let ((restore-message (make-restore-message
|
||||
active-command
|
||||
current-result-object)))
|
||||
(begin
|
||||
(switch restore-message)
|
||||
(execute-command)
|
||||
(set! command-history-pos (- (length text-command) 1))
|
||||
;(loop (paint))))
|
||||
(endwin)
|
||||
(run))))
|
||||
|
||||
|
||||
|
||||
;;Ctrl+p -> History back
|
||||
; ((= ch 16)
|
||||
; (begin
|
||||
; (history-back)
|
||||
; (loop (paint))))
|
||||
|
||||
; ;;Ctrl+n -> History forward
|
||||
; ((= ch 14)
|
||||
; (begin
|
||||
; (history-forward)
|
||||
; (loop (paint))))
|
||||
|
||||
; ;;Ctrl+s -> get selection
|
||||
; ((= ch 19)
|
||||
; (let* ((message (make-selection-message active-command
|
||||
; current-result-object))
|
||||
; (marked-items (switch message)))
|
||||
; (begin
|
||||
; (add-string-to-command-buffer marked-items)
|
||||
; (loop (paint)))))
|
||||
|
||||
(else
|
||||
(begin
|
||||
(set! command-buffer (make-buffer text-command
|
||||
pos-command
|
||||
pos-command-col
|
||||
pos-command-fin-ln
|
||||
command-buffer-pos-y
|
||||
command-buffer-pos-x
|
||||
command-lines
|
||||
command-cols
|
||||
can-write-command
|
||||
command-history-pos))
|
||||
(set! command-buffer (input command-buffer ch))
|
||||
(let ((text (buffer-text command-buffer))
|
||||
(pos-line (buffer-pos-line command-buffer))
|
||||
(pos-col (buffer-pos-col command-buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln command-buffer))
|
||||
(pos-y (buffer-pos-y command-buffer))
|
||||
(pos-x (buffer-pos-x command-buffer))
|
||||
(num-lines (buffer-num-lines command-buffer))
|
||||
(num-cols (buffer-num-cols command-buffer))
|
||||
(can-write (buffer-can-write command-buffer))
|
||||
(history-pos (buffer-history-pos command-buffer)))
|
||||
(begin
|
||||
(set! text-command text)
|
||||
(set! pos-command pos-line)
|
||||
(set! pos-command-col pos-col)
|
||||
(set! pos-command-fin-ln pos-fin-ln)
|
||||
(set! command-buffer-pos-y pos-y)
|
||||
(set! command-buffer-pos-x pos-x)
|
||||
(set! command-lines num-lines)
|
||||
(set! command-cols num-cols)
|
||||
(set! can-write-command can-write)
|
||||
(set! command-history-pos history-pos)))
|
||||
(loop (paint)))))))))))))
|
||||
|
||||
|
||||
;;print and wait for input
|
||||
|
|
@ -375,32 +437,26 @@
|
|||
(reswin-x 1)
|
||||
(reswin-h (- (- (LINES) 6) comwin-h))
|
||||
(reswin-w (- (COLS) 2)))
|
||||
; (bar3-y (+ reswin-y reswin-h))
|
||||
; (bar3-x 0)
|
||||
; (bar3-h 4)
|
||||
; (bar3-w (COLS)))
|
||||
|
||||
(wclear bar1)
|
||||
(wclear bar2)
|
||||
(wclear command-win)
|
||||
(wclear result-win)
|
||||
; (wclear bar3)
|
||||
(clear)
|
||||
|
||||
(set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x))
|
||||
(set! bar2 (newwin bar2-h bar2-w bar2-y bar2-x))
|
||||
(set! command-win (newwin comwin-h comwin-w comwin-y comwin-x))
|
||||
(set! result-win (newwin reswin-h reswin-w reswin-y reswin-x))
|
||||
;(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x))
|
||||
|
||||
(box standard-screen (ascii->char 0) (ascii->char 0))
|
||||
(refresh)
|
||||
;(box bar1 (ascii->char 0) (ascii->char 0))
|
||||
;(box standard-screen (ascii->char 0) (ascii->char 0))
|
||||
;(refresh)
|
||||
(mvwaddstr bar1 0 1 "SCSH-NUIT")
|
||||
(wrefresh bar1)
|
||||
|
||||
;(mvwaddstr bar2 1 1 active-command)
|
||||
;(wrefresh bar2)
|
||||
(box bar2 (ascii->char 0) (ascii->char 0))
|
||||
(print-active-command-win bar2 bar2-w)
|
||||
|
||||
(box command-win (ascii->char 0) (ascii->char 0))
|
||||
(set! command-lines (- comwin-h 2))
|
||||
(set! command-cols (- comwin-w 3))
|
||||
|
|
@ -424,15 +480,7 @@
|
|||
(set! result-cols (- reswin-w 3))
|
||||
(print-result-buffer result-win)
|
||||
(wrefresh result-win)
|
||||
;(box bar3 (ascii->char 0) (ascii->char 0))
|
||||
;(wattron bar3 (A-REVERSE))
|
||||
;(print-bar3 (- reswin-w 3))
|
||||
;(wstandend bar3)
|
||||
;(wrefresh bar3)
|
||||
|
||||
(box bar2 (ascii->char 0) (ascii->char 0))
|
||||
(print-active-command-win bar2 bar2-w)
|
||||
|
||||
|
||||
(set! command-buffer (cur-right-pos command-win result-win comwin-h
|
||||
reswin-h command-buffer))
|
||||
|
||||
|
|
@ -458,7 +506,12 @@
|
|||
(set! can-write-command can-write)
|
||||
(set! command-history-pos history-pos)))
|
||||
|
||||
|
||||
;(refresh)
|
||||
; (wrefresh command-win)
|
||||
; (wrefresh result-win)
|
||||
; (wrefresh bar1)
|
||||
; (wrefresh bar2)
|
||||
|
||||
|
||||
(noecho)
|
||||
(keypad bar1 #t)
|
||||
|
|
@ -540,8 +593,37 @@
|
|||
(if (= 1 (string-length old))
|
||||
(cons new "")
|
||||
(cons new (substring old 1 (string-length old))))
|
||||
(loop (substring old 1 (string-length old))
|
||||
(string-append new (string (string-ref old 0)))))))))
|
||||
(if (equal? #\( (string-ref old 0))
|
||||
(let* ((nw (get-next-word-braces
|
||||
(substring old 1
|
||||
(string-length old))))
|
||||
(nw-new (car nw))
|
||||
(nw-old (cdr nw)))
|
||||
(loop nw-old (string-append new "(" nw-new)))
|
||||
(loop (substring old 1 (string-length old))
|
||||
(string-append new (string (string-ref old 0))))))))))
|
||||
|
||||
(define get-next-word-braces
|
||||
(lambda (str)
|
||||
(let loop ((old str)
|
||||
(new ""))
|
||||
(if (= 0 (string-length old))
|
||||
(cons new old)
|
||||
(if (equal? #\( (string-ref old 0))
|
||||
(let* ((nw (get-next-word-braces
|
||||
(substring old 1
|
||||
(string-length old))))
|
||||
(nw-new (car nw))
|
||||
(nw-old (cdr nw)))
|
||||
(loop nw-old (string-append new "(" nw-new)))
|
||||
(if (equal? #\) (string-ref old 0))
|
||||
(cons (string-append new ")")
|
||||
(substring old 1 (string-length old)))
|
||||
(loop (substring old 1 (string-length old))
|
||||
(string-append new (string (string-ref old 0))))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -697,7 +779,7 @@
|
|||
(begin
|
||||
(if (not (standard-result-obj? current-result-object))
|
||||
(set! line
|
||||
(if (>= (string-length line) (- result-cols 2))
|
||||
(if (> (string-length line) result-cols)
|
||||
(let ((start-line
|
||||
(substring line 0
|
||||
(- (ceiling (/ result-cols 2))
|
||||
|
|
@ -915,6 +997,7 @@
|
|||
(set! history '())
|
||||
(set! history-pos 0)
|
||||
(set! active-command "")
|
||||
(set! active-parameters "")
|
||||
(set! current-result-object init-std-res)
|
||||
(set! active-keyboard-interrupt #f))))
|
||||
|
||||
|
|
@ -1005,6 +1088,19 @@
|
|||
|
||||
|
||||
;useful helpers
|
||||
(define get-marked-positions-1
|
||||
(lambda (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
|
||||
(lambda (all-items marked-items)
|
||||
(let loop ((count 0)
|
||||
|
|
|
|||
|
|
@ -15,4 +15,6 @@
|
|||
handle-fatal-error
|
||||
directory-files
|
||||
find
|
||||
cd))
|
||||
cd
|
||||
browse-directory-list
|
||||
browse-list))
|
||||
|
|
|
|||
Loading…
Reference in New Issue