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

Some architecural changes (message-communication).

This commit is contained in:
demattia 2004-10-03 09:13:30 +00:00
parent 9e9653e404
commit 1e10cf6b1e
3 changed files with 1235 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

311
scheme/directory-files.scm Normal file
View File

@ -0,0 +1,311 @@
;;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))))))
;;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)))
(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)))))))
;;Receiver für directory-files
(define dir-files-receiver
(lambda (message)
(cond
((next-command-message? message)
(let* ((command (next-command-string message))
(result (evaluate command))
(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))
((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
(dirfiles-result-object-file-list model)
(dirfiles-result-object-marked-items model))))
(make-print-object posy posx text (list posy) marked-pos)))
((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 (string-append (cwd) "/" 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))))
((restore-message? message)
;(let ((model (restore-message-object message)))
;(chdir (dirfiles-result-object-initial-wd model))))
(chdir initial-working-directory))
((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))))
(define dir-files-rec
(make-receiver "(directory-files)" dir-files-receiver))
(define receivers (cons dir-files-rec '()))

1321
scheme/nuit-engine.scm
View File

File diff suppressed because it is too large Load Diff

6
scheme/nuit-packages.scm
View File

@ -9,6 +9,8 @@
signals
handle
ncurses
srfi-6)
srfi-6
rt-modules)
(files nuit-engine
handle-fatal-error))
handle-fatal-error
directory-files))