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

new commands added

This commit is contained in:
demattia 2004-10-10 13:22:25 +00:00
parent b046dc8592
commit c41e53c747
6 changed files with 827 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
scheme/cd.scm Normal file
View File

@ -0,0 +1,194 @@
;;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)))))))
(define cd-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)))
(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))))))
((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)))
((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))))
((restore-message? message)
values)
((selection-message? message)
""))))
(define cd-rec (make-receiver "cd" cd-receiver))
(set! receivers (cons cd-rec receivers))

183
scheme/directory-files.scm
View File

@ -66,62 +66,66 @@
;;Auswahl->absteigen ;;Auswahl->absteigen
(define selected-dirfiles (define selected-dirfiles
(lambda (model) (lambda (model)
(let ((ln (dirfiles-result-object-pos-y model))) (let ((ln (dirfiles-result-object-pos-y model))
(if (or (>= ln (+ (length (dirfiles-result-object-result-text model)) 1)) (wd (dirfiles-result-object-working-directory model)))
(<= ln 1)) (begin (chdir wd)
model (if (or (>= ln (+ (length
(if (= ln 2) (dirfiles-result-object-result-text model)) 1))
(if (not (equal? "/" (cwd))) (<= ln 1))
(begin model
(chdir "..") (if (= ln 2)
(let* ((new-result (evaluate "(directory-files)")) (if (not (equal? "/" (cwd)))
(new-result-string (exp->string new-result)) (begin
(width (dirfiles-result-object-width model)) (chdir "..")
(new-text (layout-result-dirfiles (let* ((new-result (evaluate "(directory-files)"))
new-result-string new-result width)) (new-result-string (exp->string new-result))
(new-model (make-dirfiles-result-object (width (dirfiles-result-object-width model))
2 (new-text (layout-result-dirfiles
1 new-result-string
new-result new-result width))
new-text (new-model (make-dirfiles-result-object
(cwd) 2
width 1
(dirfiles-result-object-initial-wd new-result
model) new-text
(dirfiles-result-object-marked-items (cwd)
model) width
(dirfiles-result-object-res-marked-items (dirfiles-result-object-initial-wd
model)))) model)
new-model)) (dirfiles-result-object-marked-items
model) model)
(let* ((text (dirfiles-result-object-result-text model)) (dirfiles-result-object-res-marked-items
(ent (list-ref text (- ln 1))) model))))
(len (string-length ent)) new-model))
(last-char (substring ent (- len 1) len)) model)
(rest (substring ent 1 (- len 1)))) (let* ((text (dirfiles-result-object-result-text model))
(if (equal? last-char "/") (ent (list-ref text (- ln 1)))
(begin (len (string-length ent))
(chdir rest) (last-char (substring ent (- len 1) len))
(let* ((new-result (evaluate "(directory-files)")) (rest (substring ent 1 (- len 1))))
(new-result-string (exp->string new-result)) (if (equal? last-char "/")
(width (dirfiles-result-object-width model)) (begin
(new-text (layout-result-dirfiles (chdir rest)
new-result-string new-result width)) (let* ((new-result (evaluate "(directory-files)"))
(new-model (make-dirfiles-result-object (new-result-string (exp->string new-result))
2 (width (dirfiles-result-object-width model))
1 (new-text (layout-result-dirfiles
new-result new-result-string new-result width))
new-text (new-model (make-dirfiles-result-object
(cwd) 2
width 1
(dirfiles-result-object-initial-wd new-result
model) new-text
(dirfiles-result-object-marked-items (cwd)
model) width
(dirfiles-result-object-res-marked-items (dirfiles-result-object-initial-wd
model)))) model)
new-model)) (dirfiles-result-object-marked-items
model))))))) model)
(dirfiles-result-object-res-marked-items
model))))
new-model))
model))))))))
;;Receiver für directory-files ;;Receiver für directory-files
@ -131,7 +135,7 @@
((next-command-message? message) ((next-command-message? message)
(let* ((command (next-command-string message)) (let* ((command (next-command-string message))
(result (evaluate command)) (result (evaluate "(directory-files)"))
(result-string (exp->string result)) (result-string (exp->string result))
(width (next-command-message-width message)) (width (next-command-message-width message))
(text (layout-result-dirfiles result-string result width)) (text (layout-result-dirfiles result-string result width))
@ -144,7 +148,7 @@
(posy (dirfiles-result-object-pos-y model)) (posy (dirfiles-result-object-pos-y model))
(posx (dirfiles-result-object-pos-x model)) (posx (dirfiles-result-object-pos-x model))
(text (dirfiles-result-object-result-text model)) (text (dirfiles-result-object-result-text model))
(marked-pos (get-marked-positions (marked-pos (get-marked-positions-3
(dirfiles-result-object-file-list model) (dirfiles-result-object-file-list model)
(dirfiles-result-object-marked-items model)))) (dirfiles-result-object-marked-items model))))
(make-print-object posy posx text (list posy) marked-pos))) (make-print-object posy posx text (list posy) marked-pos)))
@ -211,30 +215,34 @@
(all-items (dirfiles-result-object-file-list model))) (all-items (dirfiles-result-object-file-list model)))
(if (<= actual-pos 2) (if (<= actual-pos 2)
model model
(let* ((actual-item (list-ref all-items (- actual-pos 3))) (let ((actual-item (list-ref all-items (- actual-pos 3)))
(actual-res-item (string-append (cwd) "/" actual-item))) (actual-res-item #f))
(if (member actual-res-item marked-items) (begin
model (if (not (equal? (cwd) "/"))
(let* ((new-res-marked-items (append res-marked-items (set! actual-res-item (string-append (cwd) "/" actual-item))
(list (set! actual-res-item (string-append "/" actual-item)))
actual-res-item))) (if (member actual-res-item marked-items)
(new-marked-items (append marked-items model
(list actual-item))) (let* ((new-res-marked-items (append res-marked-items
(new-model (make-dirfiles-result-object (list
(dirfiles-result-object-pos-y model) actual-res-item)))
(dirfiles-result-object-pos-x model) (new-marked-items (append marked-items
(dirfiles-result-object-file-list (list actual-item)))
model) (new-model (make-dirfiles-result-object
(dirfiles-result-object-result-text (dirfiles-result-object-pos-y model)
model) (dirfiles-result-object-pos-x model)
(dirfiles-result-object-working-directory (dirfiles-result-object-file-list
model) model)
(dirfiles-result-object-width model) (dirfiles-result-object-result-text
(dirfiles-result-object-initial-wd model)
model) (dirfiles-result-object-working-directory
new-marked-items model)
new-res-marked-items))) (dirfiles-result-object-width model)
new-model)))))) (dirfiles-result-object-initial-wd
model)
new-marked-items
new-res-marked-items)))
new-model)))))))
;;Ctrl+u -> aus Auswahl rausnehmen ;;Ctrl+u -> aus Auswahl rausnehmen
((= key 21) ((= key 21)
@ -304,8 +312,13 @@
(else values)))) (else values))))
(define dir-files-rec (define dir-files-rec1
(make-receiver "(directory-files)" dir-files-receiver)) (make-receiver "directory-files" dir-files-receiver))
(define receivers (cons dir-files-rec '())) (set! receivers (cons dir-files-rec1 receivers))
(define dir-files-rec2
(make-receiver "ls" dir-files-receiver))
(set! receivers (cons dir-files-rec2 receivers))

185
scheme/find.scm Normal file
View File

@ -0,0 +1,185 @@
;;find
;;This extension uses the unix-tool "find". You can only use this command in
;;if "find" is present in your environment.
;;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 find-receiver
(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)))
((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)))
((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))))
((restore-message? message)
values)
((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))))))))
(define find-rec (make-receiver "find" find-receiver))
(set! receivers (cons find-rec receivers))

3
scheme/handle-fatal-error.scm
View File

@ -43,7 +43,8 @@
((call-with-current-continuation ((call-with-current-continuation
(lambda (k) (lambda (k)
(with-handler (lambda (condition more) (with-handler (lambda (condition more)
(if (error? condition) (if (or (error? condition)
(warning? condition))
(call-with-current-continuation (call-with-current-continuation
(lambda (decline) (lambda (decline)
(k (lambda () (handler condition decline)))))) (k (lambda () (handler condition decline))))))

476
scheme/nuit-engine.scm
View File

@ -1,3 +1,6 @@
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
;;This is the "heart" of NUIT. ;;This is the "heart" of NUIT.
;;In a central loop the program waits for input (with wgetch). ;;In a central loop the program waits for input (with wgetch).
;;In the upper buffer simply the functionalities of scsh-ncurses: ;;In the upper buffer simply the functionalities of scsh-ncurses:
@ -18,11 +21,14 @@
(define result-win) (define result-win)
(define shortcuts '("F1:Exit" (define shortcuts '("F1:Exit"
"F2:Repaint (after change of buffer size)"
"Ctrl+d:Switch Buffer" "Ctrl+d:Switch Buffer"
"Ctrl+s:Insert/Select" "Ctrl+s:Insert/Select"
"Ctrl+u:-/Unselect" "Ctrl+u:-/Unselect"
"Ctrl+p:History->prev" "Ctrl+p:Result-History->prev"
"Ctrl+n:History->next" "Ctrl+n:Result-History->next"
"Ctrl+f:Command-History->forward"
"Ctrl+b:Command-History->back"
"Ctrl+a:First Pos" "Ctrl+a:First Pos"
"Ctrl+e:End")) "Ctrl+e:End"))
@ -67,7 +73,7 @@
;;state of the lower window (Result-Window) ;;state of the lower window (Result-Window)
;;---------------------------- ;;----------------------------
;;Text ;;Text
(define text-result (list "Start entering commands.")) (define text-result (list "Type 'shortcuts' for help"))
;;line of the result-window ;;line of the result-window
(define pos-result 0) (define pos-result 0)
@ -111,18 +117,26 @@
;;data-type for history.entries ;;data-type for history.entries
(define-record-type history-entry history-entry (define-record-type history-entry history-entry
(make-history-entry command (make-history-entry command
parameters
result-object) result-object)
history-entry? history-entry?
(command history-entry-command) (command history-entry-command)
(parameters history-entry-parameters)
(result-object history-entry-result-object)) (result-object history-entry-result-object))
;;active command ;;active command
(define active-command "") (define active-command "")
;;sctive parameters
(define active-parameters "")
;;active result-object ;;active result-object
(define current-result-object) (define current-result-object)
;;active keyboard-interrupt:
;;after each input this is set to #f.
;;If a keyboard-interrupt occurs this can be checked by looking-up this box
(define active-keyboard-interrupt #f)
;;Message-Types ;;Message-Types
;;--------------------- ;;---------------------
@ -152,10 +166,12 @@
;;print ;;print
(define-record-type print-message print-message (define-record-type print-message print-message
(make-print-message command-string (make-print-message command-string
object) object
width)
print-message? print-message?
(command-string print-message-command-string) (command-string print-message-command-string)
(object print-message-object)) (object print-message-object)
(width print-message-width))
;;->this sort of data-type is returned by a print-message ;;->this sort of data-type is returned by a print-message
(define-record-type print-object print-object (define-record-type print-object print-object
@ -195,9 +211,17 @@
(command receiver-command) (command receiver-command)
(rec receiver-rec)) (rec receiver-rec))
;;This list contains all the receivers that have been registered.
(define receivers '())
;;************************************************************************* ;;*************************************************************************
;;Actions ;;Actions
;;start the whole thing
(define nuit
(lambda ()
(run)))
;;handle input ;;handle input
(define run (define run
(lambda () (lambda ()
@ -211,6 +235,12 @@
(set! command-win (newwin 0 0 0 0)) (set! command-win (newwin 0 0 0 0))
(set! result-win (newwin 0 0 0 0)) (set! result-win (newwin 0 0 0 0))
;;Handling Keyboard-interrupts
;;If a keyboard-interrupt occurs it is stored in "active-keyboard-interrupt"
(set-interrupt-handler interrupt/keyboard
(lambda a
(set! active-keyboard-interrupt a)))
;;Loop ;;Loop
(let loop ((ch (paint))) (let loop ((ch (paint)))
(cond (cond
@ -223,8 +253,14 @@
(let ((restore-message (make-restore-message (let ((restore-message (make-restore-message
active-command active-command
current-result-object))) current-result-object)))
(switch restore-message)) (switch restore-message)
(endwin))) (restore-state))
(endwin)
(display "")))
((= ch key-f2)
(endwin)
(run))
;;Ctrl+f -> switch buffer ;;Ctrl+f -> switch buffer
((= ch 4) ((= ch 4)
@ -253,7 +289,9 @@
(begin (begin
(execute-command) (execute-command)
(set! command-history-pos (- (length text-command) 1)) (set! command-history-pos (- (length text-command) 1))
(loop (paint)))) ;(loop (paint))))
(endwin)
(run)))
@ -320,47 +358,49 @@
(lambda () (lambda ()
(begin (begin
(init-screen) (init-screen)
(cbreak) ;(cbreak)
(let* ((bar1-y 0) (let* ((bar1-y 1)
(bar1-x 0) (bar1-x 1)
(bar1-h 3) (bar1-h 2)
(bar1-w (COLS)) (bar1-w (- (COLS) 2))
(bar2-y (round (/ (LINES) 3))) (bar2-y (+ (round (/ (LINES) 3)) 2))
(bar2-x 0) (bar2-x 1)
(bar2-h 3) (bar2-h 3)
(bar2-w (COLS)) (bar2-w (- (COLS) 2))
(comwin-y 3) (comwin-y 2)
(comwin-x 0) (comwin-x 1)
(comwin-h (- bar2-y 3)) (comwin-h (- bar2-y 2))
(comwin-w (COLS)) (comwin-w (- (COLS) 2))
(reswin-y (+ bar2-y 3)) (reswin-y (+ bar2-y 3))
(reswin-x 0) (reswin-x 1)
(reswin-h (- (- (- (LINES) 6) comwin-h) 4)) (reswin-h (- (- (LINES) 6) comwin-h))
(reswin-w (COLS)) (reswin-w (- (COLS) 2)))
(bar3-y (+ reswin-y reswin-h)) ; (bar3-y (+ reswin-y reswin-h))
(bar3-x 0) ; (bar3-x 0)
(bar3-h 4) ; (bar3-h 4)
(bar3-w (COLS))) ; (bar3-w (COLS)))
(wclear bar1) (wclear bar1)
(wclear bar2) (wclear bar2)
(wclear command-win) (wclear command-win)
(wclear result-win) (wclear result-win)
(wclear bar3) ; (wclear bar3)
(clear) (clear)
(set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x)) (set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x))
(set! bar2 (newwin bar2-h bar2-w bar2-y bar2-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! command-win (newwin comwin-h comwin-w comwin-y comwin-x))
(set! result-win (newwin reswin-h reswin-w reswin-y reswin-x)) (set! result-win (newwin reswin-h reswin-w reswin-y reswin-x))
(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x)) ;(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x))
(box bar1 (ascii->char 0) (ascii->char 0)) (box standard-screen (ascii->char 0) (ascii->char 0))
(mvwaddstr bar1 1 1 "Command") (refresh)
;(box bar1 (ascii->char 0) (ascii->char 0))
(mvwaddstr bar1 0 1 "SCSH-NUIT")
(wrefresh bar1) (wrefresh bar1)
(box bar2 (ascii->char 0) (ascii->char 0))
(mvwaddstr bar2 1 1 "Result") ;(mvwaddstr bar2 1 1 active-command)
(wrefresh bar2) ;(wrefresh bar2)
(box command-win (ascii->char 0) (ascii->char 0)) (box command-win (ascii->char 0) (ascii->char 0))
(set! command-lines (- comwin-h 2)) (set! command-lines (- comwin-h 2))
(set! command-cols (- comwin-w 3)) (set! command-cols (- comwin-w 3))
@ -384,11 +424,14 @@
(set! result-cols (- reswin-w 3)) (set! result-cols (- reswin-w 3))
(print-result-buffer result-win) (print-result-buffer result-win)
(wrefresh result-win) (wrefresh result-win)
(box bar3 (ascii->char 0) (ascii->char 0)) ;(box bar3 (ascii->char 0) (ascii->char 0))
(wattron bar3 (A-REVERSE)) ;(wattron bar3 (A-REVERSE))
(print-bar3 (- reswin-w 3)) ;(print-bar3 (- reswin-w 3))
(wstandend bar3) ;(wstandend bar3)
(wrefresh 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 (set! command-buffer (cur-right-pos command-win result-win comwin-h
reswin-h command-buffer)) reswin-h command-buffer))
@ -415,8 +458,11 @@
(set! can-write-command can-write) (set! can-write-command can-write)
(set! command-history-pos history-pos))) (set! command-history-pos history-pos)))
(noecho) (noecho)
(keypad bar1 #t) (keypad bar1 #t)
(set! active-keyboard-interrupt #f)
(let ((ch (wgetch bar1))) (let ((ch (wgetch bar1)))
(echo) (echo)
ch ch
@ -427,15 +473,22 @@
;;which has to be executed. ;;which has to be executed.
(define execute-command (define execute-command
(lambda () (lambda ()
(let* ((command (list-ref text-command (- (length text-command) 1))) (let* ((com (list-ref text-command (- (length text-command) 1)))
;;todo: parameters (com-par (extract-com-and-par com))
(message (make-next-command-message command '() result-cols)) (command (car com-par))
(parameters (cdr com-par))
;;todo: parameters
(message (make-next-command-message
command parameters result-cols))
(model (switch message))) (model (switch message)))
(begin (begin
(if (not (= history-pos 0)) (if (not (= history-pos 0))
(let ((hist-entry (make-history-entry active-command (let ((hist-entry (make-history-entry active-command
active-parameters
current-result-object)) current-result-object))
(active (make-history-entry command model))) (active (make-history-entry command
(get-param-as-str parameters)
model)))
(begin (begin
(if (< history-pos (length history)) (if (< history-pos (length history))
(set! history (append history (list hist-entry))) (set! history (append history (list hist-entry)))
@ -444,16 +497,54 @@
(- (length history) 1)) (- (length history) 1))
(list hist-entry) (list active)))) (list hist-entry) (list active))))
(set! history-pos (length history)))) (set! history-pos (length history))))
(let ((hist-entry (make-history-entry command model))) (let ((hist-entry (make-history-entry
command
(get-param-as-str parameters) model)))
(begin (begin
(set! history (list hist-entry)) (set! history (list hist-entry))
(set! history-pos 1)))) (set! history-pos 1))))
(set! text-command (append text-command (list ""))) (set! text-command (append text-command (list "")))
(set! active-command command) (set! active-command command)
(set! active-parameters (get-param-as-str parameters))
(set! current-result-object model) (set! current-result-object model)
(scroll-command-buffer))))) (scroll-command-buffer)))))
;;Extracts the name of the function and its parameters
(define extract-com-and-par
(lambda (com)
(if (<= (string-length com) 0)
(cons "" '())
(if (equal? #\( (string-ref com 0))
(cons com '())
(let* ((fst-word (get-next-word com))
(command (car fst-word))
(rest (cdr fst-word)))
(let loop ((param-str rest)
(param-list '()))
(let* ((word (get-next-word param-str))
(param (car word))
(more (cdr word)))
(if (equal? "" param)
(cons command param-list)
(loop more (append param-list (list param)))))))))))
;;gets the next word from a string
(define get-next-word
(lambda (str)
(let loop ((old str)
(new ""))
(if (= 0 (string-length old))
(cons new old)
(if (equal? #\space (string-ref old 0))
(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)))))))))
;;scroll buffer after one command was entered ;;scroll buffer after one command was entered
(define scroll-command-buffer (define scroll-command-buffer
(lambda () (lambda ()
@ -554,12 +645,36 @@
(sublist l 0 height) (sublist l 0 height)
(sublist l (- pos height) height))))) (sublist l (- pos height) height)))))
;;print the active-command window:
(define print-active-command-win
(lambda (win width)
(if (<= width 25)
values
(let ((active-command (string-append active-command
active-parameters)))
(if (> (string-length active-command) (- width 25))
(let* ((com-txt (substring active-command
0
(- width 25)))
(whole-text (string-append "Active Command: "
com-txt
"...")))
(begin
(mvwaddstr win 1 2 whole-text)
(wrefresh win)))
(begin
(mvwaddstr win 1 2 (string-append "Active Command: "
active-command))
(wrefresh win)))))))
;;print the lower window ;;print the lower window
(define print-result-buffer (define print-result-buffer
(lambda (reswin) (lambda (reswin)
(let* ((print-message (make-print-message active-command (let* ((print-message (make-print-message active-command
current-result-object)) current-result-object
command-cols))
(model (switch print-message)) (model (switch print-message))
(text (print-object-text model)) (text (print-object-text model))
(pos-y (print-object-pos-y model)) (pos-y (print-object-pos-y model))
@ -579,25 +694,41 @@
(if (> pos result-lines) (if (> pos result-lines)
values values
(let ((line (list-ref lines (- pos 1)))) (let ((line (list-ref lines (- pos 1))))
(if (and (member pos highlighted-lines) (begin
(= active-buffer 2)) (if (not (standard-result-obj? current-result-object))
(begin (set! line
(wattron reswin (A-REVERSE)) (if (>= (string-length line) (- result-cols 2))
(mvwaddstr reswin pos 1 line) (let ((start-line
(wattrset reswin (A-NORMAL)) (substring line 0
(wrefresh reswin) (- (ceiling (/ result-cols 2))
(loop (+ pos 1))) 3)))
(if (member pos marked-lines) (end-line
(begin (substring line
(wattron reswin (A-BOLD)) (- (string-length line)
(mvwaddstr reswin pos 1 line) (ceiling
(wattrset reswin (A-NORMAL)) (/ result-cols 2)))
(wrefresh reswin) (string-length line))))
(loop (+ pos 1))) (string-append start-line "..." end-line))
(begin line)))
(mvwaddstr reswin pos 1 line) (if (and (member pos highlighted-lines)
(wrefresh reswin) (= active-buffer 2))
(loop (+ pos 1))))))))))))) (begin
(wattron reswin (A-REVERSE))
(mvwaddstr reswin pos 1 line)
(wattrset reswin (A-NORMAL))
(wrefresh reswin)
(loop (+ pos 1)))
(if (member pos marked-lines)
(begin
(wattron reswin (A-BOLD))
(mvwaddstr reswin pos 1 line)
(wattrset reswin (A-NORMAL))
(wrefresh reswin)
(loop (+ pos 1)))
(begin
(mvwaddstr reswin pos 1 line)
(wrefresh reswin)
(loop (+ pos 1))))))))))))))
;;visible lines ;;visible lines
(define get-right-result-lines (define get-right-result-lines
@ -668,51 +799,51 @@
(set! result-buffer-pos-x pos-result-col))))) (set! result-buffer-pos-x pos-result-col)))))
;;index of shortcuts at the bottom ; ;;index of shortcuts at the bottom
(define print-bar3 ; (define print-bar3
(lambda (width) ; (lambda (width)
(let loop ((pos 0) ; (let loop ((pos 0)
(used-width 0) ; (used-width 0)
(act-line 1)) ; (act-line 1))
(if (>= pos (length shortcuts)) ; (if (>= pos (length shortcuts))
(begin ; (begin
(let* ((num-blanks (+ (- width used-width) 1)) ; (let* ((num-blanks (+ (- width used-width) 1))
(last-string (make-string num-blanks #\space))) ; (last-string (make-string num-blanks #\space)))
(mvwaddstr bar3 act-line (+ used-width 1) last-string)) ; (mvwaddstr bar3 act-line (+ used-width 1) last-string))
(wrefresh bar3)) ; (wrefresh bar3))
(let* ((act-string (list-ref shortcuts pos)) ; (let* ((act-string (list-ref shortcuts pos))
(act-length (string-length act-string)) ; (act-length (string-length act-string))
(rest-width (- width used-width))) ; (rest-width (- width used-width)))
(if (= act-line 1) ; (if (= act-line 1)
(if (<= (+ act-length 3) rest-width) ; (if (<= (+ act-length 3) rest-width)
(if (= used-width 0) ; (if (= used-width 0)
(begin ; (begin
(mvwaddstr bar3 1 (+ used-width 1) act-string) ; (mvwaddstr bar3 1 (+ used-width 1) act-string)
(loop (+ pos 1) (+ used-width act-length) 1)) ; (loop (+ pos 1) (+ used-width act-length) 1))
(begin ; (begin
(mvwaddstr bar3 1 (+ used-width 1) ; (mvwaddstr bar3 1 (+ used-width 1)
(string-append " | " act-string)) ; (string-append " | " act-string))
(loop (+ pos 1) (+ used-width (+ 3 act-length)) ; (loop (+ pos 1) (+ used-width (+ 3 act-length))
1))) ; 1)))
(begin ; (begin
(let* ((num-blanks (+ rest-width 1)) ; (let* ((num-blanks (+ rest-width 1))
(last-string (make-string num-blanks #\space))) ; (last-string (make-string num-blanks #\space)))
(mvwaddstr bar3 1 (+ used-width 1) last-string)) ; (mvwaddstr bar3 1 (+ used-width 1) last-string))
(loop pos 0 2))) ; (loop pos 0 2)))
(if (<= (+ act-length 3) rest-width) ; (if (<= (+ act-length 3) rest-width)
(if (= used-width 0) ; (if (= used-width 0)
(begin ; (begin
(mvwaddstr bar3 2 (+ used-width 1) act-string) ; (mvwaddstr bar3 2 (+ used-width 1) act-string)
(loop (+ pos 1) (+ used-width act-length) 2)) ; (loop (+ pos 1) (+ used-width act-length) 2))
(begin ; (begin
(mvwaddstr bar3 2 (+ used-width 1) ; (mvwaddstr bar3 2 (+ used-width 1)
(string-append " | " act-string)) ; (string-append " | " act-string))
(loop (+ pos 1) (+ used-width (+ 3 act-length)) 2))) ; (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
(begin ; (begin
(let* ((num-blanks (+ rest-width 1) ) ; (let* ((num-blanks (+ rest-width 1) )
(last-string (make-string num-blanks #\space))) ; (last-string (make-string num-blanks #\space)))
(mvwaddstr bar3 2 (+ used-width 1) last-string)) ; (mvwaddstr bar3 2 (+ used-width 1) last-string))
(wrefresh bar3))))))))) ; (wrefresh bar3)))))))))
@ -723,14 +854,12 @@
values values
(let* ((hist-entry (list-ref history (- history-pos 1))) (let* ((hist-entry (list-ref history (- history-pos 1)))
(entry-com (history-entry-command hist-entry)) (entry-com (history-entry-command hist-entry))
(entry-par (history-entry-parameters hist-entry))
(entry-res-obj (history-entry-result-object hist-entry))) (entry-res-obj (history-entry-result-object hist-entry)))
(begin (begin
(set! active-command entry-com) (set! active-command entry-com)
(set! active-parameters entry-par)
(set! current-result-object entry-res-obj) (set! current-result-object entry-res-obj)
(set! text-command (append
(sublist text-command 0
(- (length text-command) 1))
(list entry-com)))
(if (> history-pos 1) (if (> history-pos 1)
(set! history-pos (- history-pos 1)))))))) (set! history-pos (- history-pos 1))))))))
@ -738,24 +867,17 @@
;;one step forward ;;one step forward
(define history-forward (define history-forward
(lambda () (lambda ()
(if (= history-pos (length history) )
(set! text-command (append
(sublist text-command 0
(- (length text-command) 1))
(list "")))
(if (> history-pos (- (length history) 1)) (if (> history-pos (- (length history) 1))
values values
(let* ((hist-entry (list-ref history history-pos)) (let* ((hist-entry (list-ref history history-pos))
(entry-com (history-entry-command hist-entry)) (entry-com (history-entry-command hist-entry))
(entry-par (history-entry-parameters hist-entry))
(entry-res-obj (history-entry-result-object hist-entry))) (entry-res-obj (history-entry-result-object hist-entry)))
(begin (begin
(set! text-command (append
(sublist text-command 0
(- (length text-command) 1))
(list entry-com)))
(set! active-command entry-com) (set! active-command entry-com)
(set! active-parameters entry-par)
(set! current-result-object entry-res-obj) (set! current-result-object entry-res-obj)
(set! history-pos (+ history-pos 1)))))))) (set! history-pos (+ history-pos 1)))))))
(define sublist (define sublist
(lambda (l pos k) (lambda (l pos k)
@ -764,6 +886,67 @@
(- (length tmp) k)))))) (- (length tmp) k))))))
;;When NUIT is closed the state has to be restored, in order to let the
;;user start again from scratch
(define restore-state
(lambda ()
(begin
(set! text-command (list "Welcome in the scsh-ncurses-ui!" ""))
(set! pos-command 2)
(set! pos-command-col 2)
(set! pos-command-fin-ln 2)
(set! command-buffer-pos-y 2)
(set! command-buffer-pos-x 2)
(set! command-lines 0)
(set! command-cols 0)
(set! can-write-command #t)
(set! command-history-pos 1)
(set! command-buffer #f)
(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! active-buffer 1)
(set! history '())
(set! history-pos 0)
(set! active-command "")
(set! current-result-object init-std-res)
(set! active-keyboard-interrupt #f))))
;;Shortcuts-receiver:
;;-------------------
;;If the user enters the command "shortcuts" a list of the included
;;shortcuts is displayed
(define-record-type shortcut-result-obj shortcut-result-obj
(make-shortcut-result-obj a)
shortcut-result-object?
(a shortcut-result-object-a))
(define shortcut-receiver
(lambda (message)
(cond
((next-command-message? message)
(make-shortcut-result-obj #t))
((print-message? message)
(make-print-object 1 1 shortcuts '() '()))
((key-pressed-message? message)
(key-pressed-message-result-model message))
((restore-message? message)
values)
((selection-message? message)
""))))
(define shortcut-rec (make-receiver "shortcuts" shortcut-receiver))
(set! receivers (cons shortcut-rec receivers))
;;Standard-Receiver ;;Standard-Receiver
;;----------------- ;;-----------------
@ -771,13 +954,16 @@
(define-record-type standard-result-obj standard-result-obj (define-record-type standard-result-obj standard-result-obj
(make-standard-result-obj cursor-pos-y (make-standard-result-obj cursor-pos-y
cursor-pos-x cursor-pos-x
result-text) result-text
result)
standard-result-obj? standard-result-obj?
(cursor-pos-y standard-result-obj-cur-pos-y) (cursor-pos-y standard-result-obj-cur-pos-y)
(cursor-pos-x standard-result-obj-cur-pos-x) (cursor-pos-x standard-result-obj-cur-pos-x)
(result-text standard-result-obj-result-text)) (result-text standard-result-obj-result-text)
(result standard-result-obj-result))
(define init-std-res (make-standard-result-obj 1 1 text-result)) (define init-std-res (make-standard-result-obj 1 1 text-result
(car text-result)))
(set! current-result-object init-std-res) (set! current-result-object init-std-res)
@ -794,13 +980,16 @@
(let* ((text (let* ((text
(layout-result-standard result-string result width)) (layout-result-standard result-string result width))
(std-obj (std-obj
(make-standard-result-obj 1 1 text))) (make-standard-result-obj 1 1 text result)))
std-obj))) std-obj)))
((print-message? message) ((print-message? message)
(let* ((model (print-message-object message)) (let* ((model (print-message-object message))
(pos-y (standard-result-obj-cur-pos-y model)) (pos-y (standard-result-obj-cur-pos-y model))
(pos-x (standard-result-obj-cur-pos-x model)) (pos-x (standard-result-obj-cur-pos-x model))
(text (standard-result-obj-result-text model))) (width (print-message-width message))
(result (standard-result-obj-result model))
(text (layout-result-standard (exp->string result)
result width)))
(make-print-object pos-y pos-x text '() '()))) (make-print-object pos-y pos-x text '() '())))
((key-pressed-message? message) ((key-pressed-message? message)
(key-pressed-message-result-model message)) (key-pressed-message-result-model message))
@ -816,7 +1005,19 @@
;useful helpers ;useful helpers
(define get-marked-positions (define get-marked-positions-2
(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 2))))
(loop (+ count 1) result)))))))
(define get-marked-positions-3
(lambda (all-items marked-items) (lambda (all-items marked-items)
(let loop ((count 0) (let loop ((count 0)
(result '())) (result '()))
@ -828,7 +1029,6 @@
(append result (list (+ count 3)))) (append result (list (+ count 3))))
(loop (+ count 1) result))))))) (loop (+ count 1) result)))))))
;;expression as string ;;expression as string
(define exp->string (define exp->string
(lambda (exp) (lambda (exp)
@ -837,9 +1037,6 @@
(write exp exp-port) (write exp exp-port)
(get-output-string exp-port))))) (get-output-string exp-port)))))
;;seperate a long line into pieces, each fitting into a smaller line. ;;seperate a long line into pieces, each fitting into a smaller line.
(define seperate-line (define seperate-line
(lambda (line width) (lambda (line width)
@ -856,3 +1053,14 @@
(loop (cons next-line new) rest-old)))))) (loop (cons next-line new) rest-old))))))
(define get-param-as-str
(lambda (param-lst)
(let loop ((lst param-lst)
(str ""))
(if (null? lst)
str
(loop (cdr lst)
(string-append str " " (car lst)))))))

6
scheme/nuit-packages.scm
View File

@ -1,5 +1,5 @@
(define-interface nuit-interface (define-interface nuit-interface
(export run)) (export nuit))
(define-structure nuit nuit-interface (define-structure nuit nuit-interface
(open scheme-with-scsh (open scheme-with-scsh
@ -13,4 +13,6 @@
rt-modules) rt-modules)
(files nuit-engine (files nuit-engine
handle-fatal-error handle-fatal-error
directory-files)) directory-files
find
cd))