new commands added
This commit is contained in:
demattia
parent
b046dc8592
commit
c41e53c747
|
|
@ -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))
|
||||
|
|
@ -66,8 +66,11 @@
|
|||
;;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))
|
||||
(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)
|
||||
|
|
@ -78,7 +81,8 @@
|
|||
(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-result-string
|
||||
new-result width))
|
||||
(new-model (make-dirfiles-result-object
|
||||
2
|
||||
1
|
||||
|
|
@ -121,7 +125,7 @@
|
|||
(dirfiles-result-object-res-marked-items
|
||||
model))))
|
||||
new-model))
|
||||
model)))))))
|
||||
model))))))))
|
||||
|
||||
|
||||
;;Receiver für directory-files
|
||||
|
|
@ -131,7 +135,7 @@
|
|||
|
||||
((next-command-message? message)
|
||||
(let* ((command (next-command-string message))
|
||||
(result (evaluate command))
|
||||
(result (evaluate "(directory-files)"))
|
||||
(result-string (exp->string result))
|
||||
(width (next-command-message-width message))
|
||||
(text (layout-result-dirfiles result-string result width))
|
||||
|
|
@ -144,7 +148,7 @@
|
|||
(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
|
||||
(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)))
|
||||
|
|
@ -211,8 +215,12 @@
|
|||
(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)))
|
||||
(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
|
||||
|
|
@ -234,7 +242,7 @@
|
|||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items)))
|
||||
new-model))))))
|
||||
new-model)))))))
|
||||
|
||||
;;Ctrl+u -> aus Auswahl rausnehmen
|
||||
((= key 21)
|
||||
|
|
@ -304,8 +312,13 @@
|
|||
(else values))))
|
||||
|
||||
|
||||
(define dir-files-rec
|
||||
(make-receiver "(directory-files)" dir-files-receiver))
|
||||
(define dir-files-rec1
|
||||
(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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -43,7 +43,8 @@
|
|||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-handler (lambda (condition more)
|
||||
(if (error? condition)
|
||||
(if (or (error? condition)
|
||||
(warning? condition))
|
||||
(call-with-current-continuation
|
||||
(lambda (decline)
|
||||
(k (lambda () (handler condition decline))))))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
|
||||
|
||||
|
||||
;;This is the "heart" of NUIT.
|
||||
;;In a central loop the program waits for input (with wgetch).
|
||||
;;In the upper buffer simply the functionalities of scsh-ncurses:
|
||||
|
|
@ -18,11 +21,14 @@
|
|||
(define result-win)
|
||||
|
||||
(define shortcuts '("F1:Exit"
|
||||
"F2:Repaint (after change of buffer size)"
|
||||
"Ctrl+d:Switch Buffer"
|
||||
"Ctrl+s:Insert/Select"
|
||||
"Ctrl+u:-/Unselect"
|
||||
"Ctrl+p:History->prev"
|
||||
"Ctrl+n:History->next"
|
||||
"Ctrl+p:Result-History->prev"
|
||||
"Ctrl+n:Result-History->next"
|
||||
"Ctrl+f:Command-History->forward"
|
||||
"Ctrl+b:Command-History->back"
|
||||
"Ctrl+a:First Pos"
|
||||
"Ctrl+e:End"))
|
||||
|
||||
|
|
@ -67,7 +73,7 @@
|
|||
;;state of the lower window (Result-Window)
|
||||
;;----------------------------
|
||||
;;Text
|
||||
(define text-result (list "Start entering commands."))
|
||||
(define text-result (list "Type 'shortcuts' for help"))
|
||||
|
||||
;;line of the result-window
|
||||
(define pos-result 0)
|
||||
|
|
@ -111,18 +117,26 @@
|
|||
;;data-type for history.entries
|
||||
(define-record-type history-entry history-entry
|
||||
(make-history-entry command
|
||||
parameters
|
||||
result-object)
|
||||
history-entry?
|
||||
(command history-entry-command)
|
||||
(parameters history-entry-parameters)
|
||||
(result-object history-entry-result-object))
|
||||
|
||||
;;active command
|
||||
(define active-command "")
|
||||
|
||||
;;sctive parameters
|
||||
(define active-parameters "")
|
||||
|
||||
;;active 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
|
||||
;;---------------------
|
||||
|
|
@ -152,10 +166,12 @@
|
|||
;;print
|
||||
(define-record-type print-message print-message
|
||||
(make-print-message command-string
|
||||
object)
|
||||
object
|
||||
width)
|
||||
print-message?
|
||||
(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
|
||||
(define-record-type print-object print-object
|
||||
|
|
@ -195,9 +211,17 @@
|
|||
(command receiver-command)
|
||||
(rec receiver-rec))
|
||||
|
||||
;;This list contains all the receivers that have been registered.
|
||||
(define receivers '())
|
||||
|
||||
;;*************************************************************************
|
||||
;;Actions
|
||||
|
||||
;;start the whole thing
|
||||
(define nuit
|
||||
(lambda ()
|
||||
(run)))
|
||||
|
||||
;;handle input
|
||||
(define run
|
||||
(lambda ()
|
||||
|
|
@ -211,6 +235,12 @@
|
|||
(set! command-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
|
||||
(let loop ((ch (paint)))
|
||||
(cond
|
||||
|
|
@ -223,8 +253,14 @@
|
|||
(let ((restore-message (make-restore-message
|
||||
active-command
|
||||
current-result-object)))
|
||||
(switch restore-message))
|
||||
(endwin)))
|
||||
(switch restore-message)
|
||||
(restore-state))
|
||||
(endwin)
|
||||
(display "")))
|
||||
|
||||
((= ch key-f2)
|
||||
(endwin)
|
||||
(run))
|
||||
|
||||
;;Ctrl+f -> switch buffer
|
||||
((= ch 4)
|
||||
|
|
@ -253,7 +289,9 @@
|
|||
(begin
|
||||
(execute-command)
|
||||
(set! command-history-pos (- (length text-command) 1))
|
||||
(loop (paint))))
|
||||
;(loop (paint))))
|
||||
(endwin)
|
||||
(run)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -320,47 +358,49 @@
|
|||
(lambda ()
|
||||
(begin
|
||||
(init-screen)
|
||||
(cbreak)
|
||||
(let* ((bar1-y 0)
|
||||
(bar1-x 0)
|
||||
(bar1-h 3)
|
||||
(bar1-w (COLS))
|
||||
(bar2-y (round (/ (LINES) 3)))
|
||||
(bar2-x 0)
|
||||
;(cbreak)
|
||||
(let* ((bar1-y 1)
|
||||
(bar1-x 1)
|
||||
(bar1-h 2)
|
||||
(bar1-w (- (COLS) 2))
|
||||
(bar2-y (+ (round (/ (LINES) 3)) 2))
|
||||
(bar2-x 1)
|
||||
(bar2-h 3)
|
||||
(bar2-w (COLS))
|
||||
(comwin-y 3)
|
||||
(comwin-x 0)
|
||||
(comwin-h (- bar2-y 3))
|
||||
(comwin-w (COLS))
|
||||
(bar2-w (- (COLS) 2))
|
||||
(comwin-y 2)
|
||||
(comwin-x 1)
|
||||
(comwin-h (- bar2-y 2))
|
||||
(comwin-w (- (COLS) 2))
|
||||
(reswin-y (+ bar2-y 3))
|
||||
(reswin-x 0)
|
||||
(reswin-h (- (- (- (LINES) 6) comwin-h) 4))
|
||||
(reswin-w (COLS))
|
||||
(bar3-y (+ reswin-y reswin-h))
|
||||
(bar3-x 0)
|
||||
(bar3-h 4)
|
||||
(bar3-w (COLS)))
|
||||
(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)
|
||||
; (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))
|
||||
;(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x))
|
||||
|
||||
(box bar1 (ascii->char 0) (ascii->char 0))
|
||||
(mvwaddstr bar1 1 1 "Command")
|
||||
(box standard-screen (ascii->char 0) (ascii->char 0))
|
||||
(refresh)
|
||||
;(box bar1 (ascii->char 0) (ascii->char 0))
|
||||
(mvwaddstr bar1 0 1 "SCSH-NUIT")
|
||||
(wrefresh bar1)
|
||||
(box bar2 (ascii->char 0) (ascii->char 0))
|
||||
(mvwaddstr bar2 1 1 "Result")
|
||||
(wrefresh bar2)
|
||||
|
||||
;(mvwaddstr bar2 1 1 active-command)
|
||||
;(wrefresh bar2)
|
||||
(box command-win (ascii->char 0) (ascii->char 0))
|
||||
(set! command-lines (- comwin-h 2))
|
||||
(set! command-cols (- comwin-w 3))
|
||||
|
|
@ -384,11 +424,14 @@
|
|||
(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 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))
|
||||
|
|
@ -415,8 +458,11 @@
|
|||
(set! can-write-command can-write)
|
||||
(set! command-history-pos history-pos)))
|
||||
|
||||
|
||||
|
||||
(noecho)
|
||||
(keypad bar1 #t)
|
||||
(set! active-keyboard-interrupt #f)
|
||||
(let ((ch (wgetch bar1)))
|
||||
(echo)
|
||||
ch
|
||||
|
|
@ -427,15 +473,22 @@
|
|||
;;which has to be executed.
|
||||
(define execute-command
|
||||
(lambda ()
|
||||
(let* ((command (list-ref text-command (- (length text-command) 1)))
|
||||
(let* ((com (list-ref text-command (- (length text-command) 1)))
|
||||
(com-par (extract-com-and-par com))
|
||||
(command (car com-par))
|
||||
(parameters (cdr com-par))
|
||||
;;todo: parameters
|
||||
(message (make-next-command-message command '() result-cols))
|
||||
(message (make-next-command-message
|
||||
command parameters result-cols))
|
||||
(model (switch message)))
|
||||
(begin
|
||||
(if (not (= history-pos 0))
|
||||
(let ((hist-entry (make-history-entry active-command
|
||||
active-parameters
|
||||
current-result-object))
|
||||
(active (make-history-entry command model)))
|
||||
(active (make-history-entry command
|
||||
(get-param-as-str parameters)
|
||||
model)))
|
||||
(begin
|
||||
(if (< history-pos (length history))
|
||||
(set! history (append history (list hist-entry)))
|
||||
|
|
@ -444,16 +497,54 @@
|
|||
(- (length history) 1))
|
||||
(list hist-entry) (list active))))
|
||||
(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
|
||||
(set! history (list hist-entry))
|
||||
(set! history-pos 1))))
|
||||
|
||||
(set! text-command (append text-command (list "")))
|
||||
(set! active-command command)
|
||||
(set! active-parameters (get-param-as-str parameters))
|
||||
(set! current-result-object model)
|
||||
(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
|
||||
(define scroll-command-buffer
|
||||
(lambda ()
|
||||
|
|
@ -554,12 +645,36 @@
|
|||
(sublist l 0 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
|
||||
(define print-result-buffer
|
||||
(lambda (reswin)
|
||||
(let* ((print-message (make-print-message active-command
|
||||
current-result-object))
|
||||
current-result-object
|
||||
command-cols))
|
||||
(model (switch print-message))
|
||||
(text (print-object-text model))
|
||||
(pos-y (print-object-pos-y model))
|
||||
|
|
@ -579,6 +694,22 @@
|
|||
(if (> pos result-lines)
|
||||
values
|
||||
(let ((line (list-ref lines (- pos 1))))
|
||||
(begin
|
||||
(if (not (standard-result-obj? current-result-object))
|
||||
(set! line
|
||||
(if (>= (string-length line) (- result-cols 2))
|
||||
(let ((start-line
|
||||
(substring line 0
|
||||
(- (ceiling (/ result-cols 2))
|
||||
3)))
|
||||
(end-line
|
||||
(substring line
|
||||
(- (string-length line)
|
||||
(ceiling
|
||||
(/ result-cols 2)))
|
||||
(string-length line))))
|
||||
(string-append start-line "..." end-line))
|
||||
line)))
|
||||
(if (and (member pos highlighted-lines)
|
||||
(= active-buffer 2))
|
||||
(begin
|
||||
|
|
@ -597,7 +728,7 @@
|
|||
(begin
|
||||
(mvwaddstr reswin pos 1 line)
|
||||
(wrefresh reswin)
|
||||
(loop (+ pos 1)))))))))))))
|
||||
(loop (+ pos 1))))))))))))))
|
||||
|
||||
;;visible lines
|
||||
(define get-right-result-lines
|
||||
|
|
@ -668,51 +799,51 @@
|
|||
(set! result-buffer-pos-x pos-result-col)))))
|
||||
|
||||
|
||||
;;index of shortcuts at the bottom
|
||||
(define print-bar3
|
||||
(lambda (width)
|
||||
(let loop ((pos 0)
|
||||
(used-width 0)
|
||||
(act-line 1))
|
||||
(if (>= pos (length shortcuts))
|
||||
(begin
|
||||
(let* ((num-blanks (+ (- width used-width) 1))
|
||||
(last-string (make-string num-blanks #\space)))
|
||||
(mvwaddstr bar3 act-line (+ used-width 1) last-string))
|
||||
(wrefresh bar3))
|
||||
(let* ((act-string (list-ref shortcuts pos))
|
||||
(act-length (string-length act-string))
|
||||
(rest-width (- width used-width)))
|
||||
(if (= act-line 1)
|
||||
(if (<= (+ act-length 3) rest-width)
|
||||
(if (= used-width 0)
|
||||
(begin
|
||||
(mvwaddstr bar3 1 (+ used-width 1) act-string)
|
||||
(loop (+ pos 1) (+ used-width act-length) 1))
|
||||
(begin
|
||||
(mvwaddstr bar3 1 (+ used-width 1)
|
||||
(string-append " | " act-string))
|
||||
(loop (+ pos 1) (+ used-width (+ 3 act-length))
|
||||
1)))
|
||||
(begin
|
||||
(let* ((num-blanks (+ rest-width 1))
|
||||
(last-string (make-string num-blanks #\space)))
|
||||
(mvwaddstr bar3 1 (+ used-width 1) last-string))
|
||||
(loop pos 0 2)))
|
||||
(if (<= (+ act-length 3) rest-width)
|
||||
(if (= used-width 0)
|
||||
(begin
|
||||
(mvwaddstr bar3 2 (+ used-width 1) act-string)
|
||||
(loop (+ pos 1) (+ used-width act-length) 2))
|
||||
(begin
|
||||
(mvwaddstr bar3 2 (+ used-width 1)
|
||||
(string-append " | " act-string))
|
||||
(loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
|
||||
(begin
|
||||
(let* ((num-blanks (+ rest-width 1) )
|
||||
(last-string (make-string num-blanks #\space)))
|
||||
(mvwaddstr bar3 2 (+ used-width 1) last-string))
|
||||
(wrefresh bar3)))))))))
|
||||
; ;;index of shortcuts at the bottom
|
||||
; (define print-bar3
|
||||
; (lambda (width)
|
||||
; (let loop ((pos 0)
|
||||
; (used-width 0)
|
||||
; (act-line 1))
|
||||
; (if (>= pos (length shortcuts))
|
||||
; (begin
|
||||
; (let* ((num-blanks (+ (- width used-width) 1))
|
||||
; (last-string (make-string num-blanks #\space)))
|
||||
; (mvwaddstr bar3 act-line (+ used-width 1) last-string))
|
||||
; (wrefresh bar3))
|
||||
; (let* ((act-string (list-ref shortcuts pos))
|
||||
; (act-length (string-length act-string))
|
||||
; (rest-width (- width used-width)))
|
||||
; (if (= act-line 1)
|
||||
; (if (<= (+ act-length 3) rest-width)
|
||||
; (if (= used-width 0)
|
||||
; (begin
|
||||
; (mvwaddstr bar3 1 (+ used-width 1) act-string)
|
||||
; (loop (+ pos 1) (+ used-width act-length) 1))
|
||||
; (begin
|
||||
; (mvwaddstr bar3 1 (+ used-width 1)
|
||||
; (string-append " | " act-string))
|
||||
; (loop (+ pos 1) (+ used-width (+ 3 act-length))
|
||||
; 1)))
|
||||
; (begin
|
||||
; (let* ((num-blanks (+ rest-width 1))
|
||||
; (last-string (make-string num-blanks #\space)))
|
||||
; (mvwaddstr bar3 1 (+ used-width 1) last-string))
|
||||
; (loop pos 0 2)))
|
||||
; (if (<= (+ act-length 3) rest-width)
|
||||
; (if (= used-width 0)
|
||||
; (begin
|
||||
; (mvwaddstr bar3 2 (+ used-width 1) act-string)
|
||||
; (loop (+ pos 1) (+ used-width act-length) 2))
|
||||
; (begin
|
||||
; (mvwaddstr bar3 2 (+ used-width 1)
|
||||
; (string-append " | " act-string))
|
||||
; (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
|
||||
; (begin
|
||||
; (let* ((num-blanks (+ rest-width 1) )
|
||||
; (last-string (make-string num-blanks #\space)))
|
||||
; (mvwaddstr bar3 2 (+ used-width 1) last-string))
|
||||
; (wrefresh bar3)))))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -723,14 +854,12 @@
|
|||
values
|
||||
(let* ((hist-entry (list-ref history (- history-pos 1)))
|
||||
(entry-com (history-entry-command hist-entry))
|
||||
(entry-par (history-entry-parameters hist-entry))
|
||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||
(begin
|
||||
(set! active-command entry-com)
|
||||
(set! active-parameters entry-par)
|
||||
(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)
|
||||
(set! history-pos (- history-pos 1))))))))
|
||||
|
||||
|
|
@ -738,24 +867,17 @@
|
|||
;;one step forward
|
||||
(define history-forward
|
||||
(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))
|
||||
values
|
||||
(let* ((hist-entry (list-ref history history-pos))
|
||||
(entry-com (history-entry-command hist-entry))
|
||||
(entry-par (history-entry-parameters hist-entry))
|
||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||
(begin
|
||||
(set! text-command (append
|
||||
(sublist text-command 0
|
||||
(- (length text-command) 1))
|
||||
(list entry-com)))
|
||||
(set! active-command entry-com)
|
||||
(set! active-parameters entry-par)
|
||||
(set! current-result-object entry-res-obj)
|
||||
(set! history-pos (+ history-pos 1))))))))
|
||||
(set! history-pos (+ history-pos 1)))))))
|
||||
|
||||
(define sublist
|
||||
(lambda (l pos k)
|
||||
|
|
@ -764,6 +886,67 @@
|
|||
(- (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
|
||||
;;-----------------
|
||||
|
||||
|
|
@ -771,13 +954,16 @@
|
|||
(define-record-type standard-result-obj standard-result-obj
|
||||
(make-standard-result-obj cursor-pos-y
|
||||
cursor-pos-x
|
||||
result-text)
|
||||
result-text
|
||||
result)
|
||||
standard-result-obj?
|
||||
(cursor-pos-y standard-result-obj-cur-pos-y)
|
||||
(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)
|
||||
|
||||
|
|
@ -794,13 +980,16 @@
|
|||
(let* ((text
|
||||
(layout-result-standard result-string result width))
|
||||
(std-obj
|
||||
(make-standard-result-obj 1 1 text)))
|
||||
(make-standard-result-obj 1 1 text result)))
|
||||
std-obj)))
|
||||
((print-message? message)
|
||||
(let* ((model (print-message-object message))
|
||||
(pos-y (standard-result-obj-cur-pos-y 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 '() '())))
|
||||
((key-pressed-message? message)
|
||||
(key-pressed-message-result-model message))
|
||||
|
|
@ -816,7 +1005,19 @@
|
|||
|
||||
|
||||
;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)
|
||||
(let loop ((count 0)
|
||||
(result '()))
|
||||
|
|
@ -828,7 +1029,6 @@
|
|||
(append result (list (+ count 3))))
|
||||
(loop (+ count 1) result)))))))
|
||||
|
||||
|
||||
;;expression as string
|
||||
(define exp->string
|
||||
(lambda (exp)
|
||||
|
|
@ -837,9 +1037,6 @@
|
|||
(write exp exp-port)
|
||||
(get-output-string exp-port)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;seperate a long line into pieces, each fitting into a smaller line.
|
||||
(define seperate-line
|
||||
(lambda (line width)
|
||||
|
|
@ -856,3 +1053,14 @@
|
|||
(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)))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-interface nuit-interface
|
||||
(export run))
|
||||
(export nuit))
|
||||
|
||||
(define-structure nuit nuit-interface
|
||||
(open scheme-with-scsh
|
||||
|
|
@ -13,4 +13,6 @@
|
|||
rt-modules)
|
||||
(files nuit-engine
|
||||
handle-fatal-error
|
||||
directory-files))
|
||||
directory-files
|
||||
find
|
||||
cd))
|
||||
|
|
|
|||
Loading…
Reference in New Issue