code cleanup
This commit is contained in:
eknauel
parent
cb680b277c
commit
63ed7f8aa9
|
|
@ -529,49 +529,42 @@
|
||||||
(loop more (append param-list (list param)))))))))))
|
(loop more (append param-list (list param)))))))))))
|
||||||
|
|
||||||
;;gets the next word from a string
|
;;gets the next word from a string
|
||||||
(define get-next-word
|
(define (get-next-word str)
|
||||||
(lambda (str)
|
(let loop ((old str)
|
||||||
(let loop ((old str)
|
(new ""))
|
||||||
(new ""))
|
(if (= 0 (string-length old))
|
||||||
(if (= 0 (string-length old))
|
(cons new old)
|
||||||
(cons new old)
|
(if (char=? #\space (string-ref old 0))
|
||||||
(if (equal? #\space (string-ref old 0))
|
(if (= 1 (string-length old))
|
||||||
(if (= 1 (string-length old))
|
(cons new "")
|
||||||
(cons new "")
|
(cons new (substring old 1 (string-length old))))
|
||||||
(cons new (substring old 1 (string-length old))))
|
(if (char=? #\( (string-ref old 0))
|
||||||
(if (equal? #\( (string-ref old 0))
|
(let* ((nw (get-next-word-braces
|
||||||
(let* ((nw (get-next-word-braces
|
(substring old 1
|
||||||
(substring old 1
|
(string-length old))))
|
||||||
(string-length old))))
|
(nw-new (car nw))
|
||||||
(nw-new (car nw))
|
(nw-old (cdr nw)))
|
||||||
(nw-old (cdr nw)))
|
(loop nw-old (string-append new "(" nw-new)))
|
||||||
(loop nw-old (string-append new "(" nw-new)))
|
(loop (substring old 1 (string-length old))
|
||||||
(loop (substring old 1 (string-length old))
|
(string-append new (string (string-ref old 0)))))))))
|
||||||
(string-append new (string (string-ref old 0))))))))))
|
|
||||||
|
|
||||||
(define get-next-word-braces
|
(define (get-next-word-braces str)
|
||||||
(lambda (str)
|
(let loop ((old str)
|
||||||
(let loop ((old str)
|
(new ""))
|
||||||
(new ""))
|
(if (= 0 (string-length old))
|
||||||
(if (= 0 (string-length old))
|
(cons new old)
|
||||||
(cons new old)
|
(if (char=? #\( (string-ref old 0))
|
||||||
(if (equal? #\( (string-ref old 0))
|
(let* ((nw (get-next-word-braces
|
||||||
(let* ((nw (get-next-word-braces
|
(substring old 1
|
||||||
(substring old 1
|
(string-length old))))
|
||||||
(string-length old))))
|
(nw-new (car nw))
|
||||||
(nw-new (car nw))
|
(nw-old (cdr nw)))
|
||||||
(nw-old (cdr nw)))
|
(loop nw-old (string-append new "(" nw-new)))
|
||||||
(loop nw-old (string-append new "(" nw-new)))
|
(if (char=? #\) (string-ref old 0))
|
||||||
(if (equal? #\) (string-ref old 0))
|
(cons (string-append new ")")
|
||||||
(cons (string-append new ")")
|
(substring old 1 (string-length old)))
|
||||||
(substring old 1 (string-length old)))
|
(loop (substring old 1 (string-length old))
|
||||||
(loop (substring old 1 (string-length old))
|
(string-append new (string (string-ref old 0)))))))))
|
||||||
(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)
|
||||||
|
|
@ -580,55 +573,48 @@
|
||||||
(set-buffer-pos-col! command-buffer 2))
|
(set-buffer-pos-col! command-buffer 2))
|
||||||
|
|
||||||
;;evaluate an expression given as a string
|
;;evaluate an expression given as a string
|
||||||
(define evaluate
|
(define (evaluate exp)
|
||||||
(lambda (exp)
|
(let* ((command-port (open-input-string exp))
|
||||||
(let* ((command-port (open-input-string exp))
|
(handler (lambda (condition more)
|
||||||
(handler (lambda (condition more)
|
(cons 'Error: condition)))
|
||||||
(cons 'Error: condition)))
|
(structure (reify-structure 'scheme-with-scsh))
|
||||||
(structure (reify-structure 'scheme-with-scsh))
|
(s (load-structure structure))
|
||||||
(s (load-structure structure))
|
(env (rt-structure->environment structure))
|
||||||
(env (rt-structure->environment structure))
|
(result (with-fatal-error-handler
|
||||||
(result (with-fatal-error-handler
|
handler
|
||||||
handler
|
(eval (read command-port) env))))
|
||||||
(eval (read command-port) env))))
|
result))
|
||||||
result)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;Message-Passing
|
;;Message-Passing
|
||||||
;;switch manages that the messages are delivered in the correct way
|
;;switch manages that the messages are delivered in the correct way
|
||||||
(define switch
|
(define (switch message)
|
||||||
(lambda (message)
|
(let ((command ""))
|
||||||
(let ((command ""))
|
(cond
|
||||||
(begin
|
((next-command-message? message)
|
||||||
(cond
|
(set! command (next-command-string message)))
|
||||||
((next-command-message? message)
|
((key-pressed-message? message)
|
||||||
(set! command (next-command-string message)))
|
(set! command (key-pressed-command-string message)))
|
||||||
((key-pressed-message? message)
|
((print-message? message)
|
||||||
(set! command (key-pressed-command-string message)))
|
(set! command (print-message-command-string message)))
|
||||||
((print-message? message)
|
((restore-message? message)
|
||||||
(set! command (print-message-command-string message)))
|
(set! command (restore-message-command-string message)))
|
||||||
((restore-message? message)
|
((selection-message? message)
|
||||||
(set! command (restore-message-command-string message)))
|
(set! command (selection-message-command-string message))))
|
||||||
((selection-message? message)
|
(let ((receiver (get-receiver command)))
|
||||||
(set! command (selection-message-command-string message))))
|
(if receiver
|
||||||
(let ((receiver (get-receiver command)))
|
(receiver message)
|
||||||
(if receiver
|
(standard-receiver message)))))
|
||||||
(receiver message)
|
|
||||||
(standard-receiver message)))))))
|
|
||||||
|
|
||||||
(define get-receiver
|
|
||||||
(lambda (command)
|
|
||||||
(let loop ((recs receivers))
|
|
||||||
(if (= 0 (length recs))
|
|
||||||
#f
|
|
||||||
(let* ((act-rec (car recs))
|
|
||||||
(act-com (receiver-command act-rec))
|
|
||||||
(act-rec-proc (receiver-rec act-rec)))
|
|
||||||
(if (equal? command act-com)
|
|
||||||
act-rec-proc
|
|
||||||
(loop (cdr recs))))))))
|
|
||||||
|
|
||||||
|
(define (get-receiver command)
|
||||||
|
(let loop ((recs receivers))
|
||||||
|
(if (= 0 (length recs))
|
||||||
|
#f
|
||||||
|
(let* ((act-rec (car recs))
|
||||||
|
(act-com (receiver-command act-rec))
|
||||||
|
(act-rec-proc (receiver-rec act-rec)))
|
||||||
|
(if (equal? command act-com)
|
||||||
|
act-rec-proc
|
||||||
|
(loop (cdr recs)))))))
|
||||||
|
|
||||||
;;Management of the upper buffer
|
;;Management of the upper buffer
|
||||||
;;add a char to the buffer
|
;;add a char to the buffer
|
||||||
|
|
@ -651,36 +637,32 @@
|
||||||
(+ (buffer-pos-col command-buffer) 1))))
|
(+ (buffer-pos-col command-buffer) 1))))
|
||||||
|
|
||||||
;;add a string to the buffer
|
;;add a string to the buffer
|
||||||
(define add-string-to-command-buffer
|
(define (add-string-to-command-buffer string)
|
||||||
(lambda (string)
|
(let loop ((str string))
|
||||||
(let loop ((str string))
|
(if (string=? str "")
|
||||||
(if (equal? str "")
|
(values)
|
||||||
(values)
|
(let ((first-ch (string-ref str 0)))
|
||||||
(let ((first-ch (string-ref str 0)))
|
(add-to-command-buffer (char->ascii first-ch))
|
||||||
(begin
|
(loop (substring str 1 (string-length str)))))))
|
||||||
(add-to-command-buffer (char->ascii first-ch))
|
|
||||||
(loop (substring str 1 (string-length str)))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;selection of the visible area of the buffer
|
;;selection of the visible area of the buffer
|
||||||
(define prepare-lines
|
(define (prepare-lines l height pos)
|
||||||
(lambda (l height pos)
|
(if (< (length l) height)
|
||||||
(if (< (length l) height)
|
(let loop ((tmp-list l))
|
||||||
(let loop ((tmp-list l))
|
(if (= height (length tmp-list))
|
||||||
(if (= height (length tmp-list))
|
tmp-list
|
||||||
tmp-list
|
(loop (append tmp-list (list "")))))
|
||||||
(loop (append tmp-list (list "")))))
|
(if (< pos height)
|
||||||
(if (< pos height)
|
(sublist l 0 height)
|
||||||
(sublist l 0 height)
|
(sublist l (- pos height) height))))
|
||||||
(sublist l (- pos height) height)))))
|
|
||||||
|
|
||||||
;;print the active-command window:
|
;;print the active-command window:
|
||||||
(define print-active-command-win
|
(define (print-active-command-win win width)
|
||||||
(lambda (win width)
|
(if (<= width 25)
|
||||||
(if (<= width 25)
|
(values)
|
||||||
(values)
|
(let ((active-command (string-append active-command
|
||||||
(let ((active-command (string-append active-command
|
active-parameters)))
|
||||||
active-parameters)))
|
|
||||||
(if (> (string-length active-command) (- width 25))
|
(if (> (string-length active-command) (- width 25))
|
||||||
(let* ((com-txt (substring active-command
|
(let* ((com-txt (substring active-command
|
||||||
0
|
0
|
||||||
|
|
@ -688,15 +670,12 @@
|
||||||
(whole-text (string-append "Active Command: "
|
(whole-text (string-append "Active Command: "
|
||||||
com-txt
|
com-txt
|
||||||
"...")))
|
"...")))
|
||||||
(begin
|
(mvwaddstr win 1 2 whole-text)
|
||||||
(mvwaddstr win 1 2 whole-text)
|
(wrefresh win))
|
||||||
(wrefresh win)))
|
|
||||||
(begin
|
(begin
|
||||||
(mvwaddstr win 1 2 (string-append "Active Command: "
|
(mvwaddstr win 1 2 (string-append "Active Command: "
|
||||||
active-command))
|
active-command))
|
||||||
(wrefresh win)))))))
|
(wrefresh win))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;print the lower window
|
;;print the lower window
|
||||||
(define (print-result-buffer result-window)
|
(define (print-result-buffer result-window)
|
||||||
|
|
@ -759,42 +738,39 @@
|
||||||
(loop (+ pos 1))))))))))))
|
(loop (+ pos 1))))))))))))
|
||||||
|
|
||||||
;;visible lines
|
;;visible lines
|
||||||
(define get-right-result-lines
|
(define (get-right-result-lines)
|
||||||
(lambda ()
|
(prepare-lines text-result result-lines pos-result))
|
||||||
(prepare-lines text-result result-lines pos-result)))
|
|
||||||
|
|
||||||
;;marked and highlighted lines
|
;;marked and highlighted lines
|
||||||
(define right-highlighted-lines
|
(define (right-highlighted-lines)
|
||||||
(lambda ()
|
(let loop ((old highlighted-lines)
|
||||||
(let loop ((old highlighted-lines)
|
(new '()))
|
||||||
(new '()))
|
(if (null? old)
|
||||||
(if (equal? '() old)
|
(set! highlighted-lines new)
|
||||||
(set! highlighted-lines new)
|
(let ((el (car old)))
|
||||||
(let ((el (car old)))
|
(if (<= pos-result result-lines)
|
||||||
(if (<= pos-result result-lines)
|
;;auf der ersten Seite
|
||||||
;;auf der ersten Seite
|
(loop (cdr old)
|
||||||
(loop (cdr old)
|
(append new (list el)))
|
||||||
(append new (list el)))
|
(let* ((offset (- pos-result result-lines))
|
||||||
(let* ((offset (- pos-result result-lines))
|
(new-el (- el offset )))
|
||||||
(new-el (- el offset )))
|
|
||||||
(loop (cdr old)
|
|
||||||
(append new (list new-el))))))))))
|
|
||||||
(define right-marked-lines
|
|
||||||
(lambda ()
|
|
||||||
(let loop ((old marked-lines)
|
|
||||||
(new '()))
|
|
||||||
(if (equal? '() old)
|
|
||||||
(set! marked-lines new)
|
|
||||||
(let ((el (car old)))
|
|
||||||
(if (<= pos-result result-lines)
|
|
||||||
;;auf der ersten Seite
|
|
||||||
(loop (cdr old)
|
(loop (cdr old)
|
||||||
(append new (list el)))
|
(append new (list new-el)))))))))
|
||||||
(let* ((offset (- pos-result result-lines))
|
|
||||||
(new-el (- el offset )))
|
|
||||||
(loop (cdr old)
|
|
||||||
(append new (list new-el))))))))))
|
|
||||||
|
|
||||||
|
(define (right-marked-lines)
|
||||||
|
(let loop ((old marked-lines)
|
||||||
|
(new '()))
|
||||||
|
(if (null? old)
|
||||||
|
(set! marked-lines new)
|
||||||
|
(let ((el (car old)))
|
||||||
|
(if (<= pos-result result-lines)
|
||||||
|
;;auf der ersten Seite
|
||||||
|
(loop (cdr old)
|
||||||
|
(append new (list el)))
|
||||||
|
(let* ((offset (- pos-result result-lines))
|
||||||
|
(new-el (- el offset )))
|
||||||
|
(loop (cdr old)
|
||||||
|
(append new (list new-el)))))))))
|
||||||
|
|
||||||
;;Cursor
|
;;Cursor
|
||||||
;;move cursor to the corrct position
|
;;move cursor to the corrct position
|
||||||
|
|
@ -810,24 +786,23 @@
|
||||||
buffer)))
|
buffer)))
|
||||||
|
|
||||||
;;compue pos-x and pos-y
|
;;compue pos-x and pos-y
|
||||||
(define compute-y-x
|
(define (compute-y-x)
|
||||||
(lambda ()
|
(if (focus-on-command-buffer?)
|
||||||
(if (focus-on-command-buffer?)
|
(begin
|
||||||
(begin
|
(if (>= (buffer-pos-fin-ln command-buffer)
|
||||||
(if (>= (buffer-pos-fin-ln command-buffer)
|
(buffer-num-lines command-buffer))
|
||||||
(buffer-num-lines command-buffer))
|
(set-buffer-pos-y! command-buffer
|
||||||
(set-buffer-pos-y! command-buffer
|
(buffer-num-lines command-buffer))
|
||||||
(buffer-num-lines command-buffer))
|
(set-buffer-pos-y! command-buffer
|
||||||
(set-buffer-pos-y! command-buffer
|
(buffer-pos-fin-ln command-buffer)))
|
||||||
(buffer-pos-fin-ln command-buffer)))
|
(let ((posx (modulo (buffer-pos-col command-buffer)
|
||||||
(let ((posx (modulo (buffer-pos-col command-buffer)
|
(buffer-num-cols command-buffer))))
|
||||||
(buffer-num-cols command-buffer))))
|
(set-buffer-pos-x! command-buffer posx)))
|
||||||
(set-buffer-pos-x! command-buffer posx)))
|
(begin
|
||||||
(begin
|
(if (>= pos-result result-lines)
|
||||||
(if (>= pos-result result-lines)
|
(set! result-buffer-pos-y result-lines)
|
||||||
(set! result-buffer-pos-y result-lines)
|
(set! result-buffer-pos-y pos-result))
|
||||||
(set! result-buffer-pos-y pos-result))
|
(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
|
||||||
|
|
@ -879,64 +854,55 @@
|
||||||
|
|
||||||
|
|
||||||
;; one step back in the history
|
;; one step back in the history
|
||||||
(define history-back
|
(define (history-back)
|
||||||
(lambda ()
|
(if (<= history-pos 0)
|
||||||
(if (<= history-pos 0)
|
(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-par (history-entry-parameters hist-entry))
|
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
(set! active-command entry-com)
|
||||||
(begin
|
(set! active-parameters entry-par)
|
||||||
(set! active-command entry-com)
|
(set! current-result-object entry-res-obj)
|
||||||
(set! active-parameters entry-par)
|
(if (> history-pos 1)
|
||||||
(set! current-result-object entry-res-obj)
|
(set! history-pos (- history-pos 1))))))
|
||||||
(if (> history-pos 1)
|
|
||||||
(set! history-pos (- history-pos 1))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;one step forward
|
;;one step forward
|
||||||
(define history-forward
|
(define (history-forward)
|
||||||
(lambda ()
|
(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-par (history-entry-parameters hist-entry))
|
(entry-res-obj (history-entry-result-object hist-entry)))
|
||||||
(entry-res-obj (history-entry-result-object hist-entry)))
|
(set! active-command entry-com)
|
||||||
(begin
|
(set! active-parameters entry-par)
|
||||||
(set! active-command entry-com)
|
(set! current-result-object entry-res-obj)
|
||||||
(set! active-parameters entry-par)
|
(set! history-pos (+ history-pos 1)))))
|
||||||
(set! current-result-object entry-res-obj)
|
|
||||||
(set! history-pos (+ history-pos 1)))))))
|
|
||||||
|
|
||||||
(define sublist
|
(define (sublist l pos k)
|
||||||
(lambda (l pos k)
|
(let ((tmp (list-tail l pos)))
|
||||||
(let ((tmp (list-tail l pos)))
|
(reverse (list-tail (reverse tmp)
|
||||||
(reverse (list-tail (reverse tmp)
|
(- (length tmp) k)))))
|
||||||
(- (length tmp) k))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;When NUIT is closed the state has to be restored, in order to let the
|
;;When NUIT is closed the state has to be restored, in order to let the
|
||||||
;;user start again from scratch
|
;;user start again from scratch
|
||||||
(define restore-state
|
(define (restore-state)
|
||||||
(lambda ()
|
(set! text-result (list "Start entering commands."))
|
||||||
(begin
|
(set! pos-result 0)
|
||||||
(set! text-result (list "Start entering commands."))
|
(set! pos-result-col 0)
|
||||||
(set! pos-result 0)
|
(set! result-buffer-pos-y 0)
|
||||||
(set! pos-result-col 0)
|
(set! result-buffer-pos-x 0)
|
||||||
(set! result-buffer-pos-y 0)
|
(set! result-lines 0)
|
||||||
(set! result-buffer-pos-x 0)
|
(set! result-cols 0)
|
||||||
(set! result-lines 0)
|
(set! highlighted-lines '())
|
||||||
(set! result-cols 0)
|
(set! marked-lines '())
|
||||||
(set! highlighted-lines '())
|
(set! history '())
|
||||||
(set! marked-lines '())
|
(set! history-pos 0)
|
||||||
(set! history '())
|
(set! active-command "")
|
||||||
(set! history-pos 0)
|
(set! active-parameters "")
|
||||||
(set! active-command "")
|
(set! current-result-object init-std-res)
|
||||||
(set! active-parameters "")
|
(set! active-keyboard-interrupt #f))
|
||||||
(set! current-result-object init-std-res)
|
|
||||||
(set! active-keyboard-interrupt #f))))
|
|
||||||
|
|
||||||
;;Shortcuts-receiver:
|
;;Shortcuts-receiver:
|
||||||
;;-------------------
|
;;-------------------
|
||||||
|
|
@ -947,19 +913,18 @@
|
||||||
shortcut-result-object?
|
shortcut-result-object?
|
||||||
(a shortcut-result-object-a))
|
(a shortcut-result-object-a))
|
||||||
|
|
||||||
(define shortcut-receiver
|
(define (shortcut-receiver message)
|
||||||
(lambda (message)
|
(cond
|
||||||
(cond
|
((next-command-message? message)
|
||||||
((next-command-message? message)
|
(make-shortcut-result-obj #t))
|
||||||
(make-shortcut-result-obj #t))
|
((print-message? message)
|
||||||
((print-message? message)
|
(make-print-object 1 1 shortcuts '() '()))
|
||||||
(make-print-object 1 1 shortcuts '() '()))
|
((key-pressed-message? message)
|
||||||
((key-pressed-message? message)
|
(key-pressed-message-result-model message))
|
||||||
(key-pressed-message-result-model message))
|
((restore-message? message)
|
||||||
((restore-message? message)
|
(values))
|
||||||
(values))
|
((selection-message? message)
|
||||||
((selection-message? message)
|
"")))
|
||||||
""))))
|
|
||||||
|
|
||||||
(define shortcut-rec (make-receiver "shortcuts" shortcut-receiver))
|
(define shortcut-rec (make-receiver "shortcuts" shortcut-receiver))
|
||||||
|
|
||||||
|
|
@ -989,108 +954,96 @@
|
||||||
|
|
||||||
|
|
||||||
;;Standard-Receiver:
|
;;Standard-Receiver:
|
||||||
(define standard-receiver
|
(define (standard-receiver message)
|
||||||
(lambda (message)
|
(cond
|
||||||
(cond
|
((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 command))
|
(result-string (exp->string result))
|
||||||
(result-string (exp->string result))
|
(width (next-command-message-width message)))
|
||||||
(width (next-command-message-width message)))
|
(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 result)))
|
||||||
(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))
|
(width (print-message-width message))
|
||||||
(width (print-message-width message))
|
(result (standard-result-obj-result model))
|
||||||
(result (standard-result-obj-result model))
|
(text (layout-result-standard (exp->string result)
|
||||||
(text (layout-result-standard (exp->string result)
|
result width)))
|
||||||
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))
|
((restore-message? message)
|
||||||
((restore-message? message)
|
(values))
|
||||||
(values))
|
((selection-message? message)
|
||||||
((selection-message? message)
|
"")))
|
||||||
""))))
|
|
||||||
|
|
||||||
;;the result is the "answer" of scsh
|
;;the result is the "answer" of scsh
|
||||||
(define layout-result-standard
|
(define (layout-result-standard result-str result width)
|
||||||
(lambda (result-str result width)
|
(reverse (seperate-line result-str width)))
|
||||||
(reverse (seperate-line result-str width))))
|
|
||||||
|
|
||||||
|
|
||||||
;useful helpers
|
;useful helpers
|
||||||
(define get-marked-positions-1
|
(define (get-marked-positions-1 all-items marked-items)
|
||||||
(lambda (all-items marked-items)
|
(let loop ((count 0)
|
||||||
(let loop ((count 0)
|
(result '()))
|
||||||
(result '()))
|
(if (>= count (length all-items))
|
||||||
(if (>= count (length all-items))
|
result
|
||||||
result
|
(let ((act-item (list-ref all-items count)))
|
||||||
(let ((act-item (list-ref all-items count)))
|
(if (member act-item marked-items)
|
||||||
(if (member act-item marked-items)
|
(loop (+ count 1)
|
||||||
(loop (+ count 1)
|
(append result (list (+ count 1))))
|
||||||
(append result (list (+ count 1))))
|
(loop (+ count 1) result))))))
|
||||||
(loop (+ count 1) result)))))))
|
|
||||||
|
|
||||||
|
(define (get-marked-positions-2 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-2
|
(define (get-marked-positions-3 all-items marked-items)
|
||||||
(lambda (all-items marked-items)
|
(let loop ((count 0)
|
||||||
(let loop ((count 0)
|
(result '()))
|
||||||
(result '()))
|
(if (>= count (length all-items))
|
||||||
(if (>= count (length all-items))
|
result
|
||||||
result
|
(let ((act-item (list-ref all-items count)))
|
||||||
(let ((act-item (list-ref all-items count)))
|
(if (member act-item marked-items)
|
||||||
(if (member act-item marked-items)
|
(loop (+ count 1)
|
||||||
(loop (+ count 1)
|
(append result (list (+ count 3))))
|
||||||
(append result (list (+ count 2))))
|
(loop (+ count 1) result))))))
|
||||||
(loop (+ count 1) result)))))))
|
|
||||||
|
|
||||||
(define get-marked-positions-3
|
|
||||||
(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 3))))
|
|
||||||
(loop (+ count 1) result)))))))
|
|
||||||
|
|
||||||
;;expression as string
|
;;expression as string
|
||||||
(define exp->string
|
(define (exp->string exp)
|
||||||
(lambda (exp)
|
(let ((exp-port (open-output-string)))
|
||||||
(let ((exp-port (open-output-string)))
|
(write exp exp-port)
|
||||||
(begin
|
(get-output-string exp-port)))
|
||||||
(write exp 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 line width)
|
||||||
(lambda (line width)
|
(let loop ((new '())
|
||||||
(let loop ((new '())
|
(old line))
|
||||||
(old line))
|
(if (> width (string-length old))
|
||||||
(if (> width (string-length old))
|
(if (= 0 (string-length old))
|
||||||
(if (= 0 (string-length old))
|
(if (equal? new '())
|
||||||
(if (equal? new '())
|
'("")
|
||||||
'("")
|
new)
|
||||||
new)
|
(append (list old) new))
|
||||||
(append (list old) new))
|
(let ((next-line (substring old 0 width))
|
||||||
(let ((next-line (substring old 0 width))
|
(rest-old (substring old width (string-length old))))
|
||||||
(rest-old (substring old width (string-length old))))
|
(loop (cons next-line new) rest-old)))))
|
||||||
(loop (cons next-line new) rest-old))))))
|
|
||||||
|
|
||||||
|
(define (get-param-as-str param-lst)
|
||||||
(define get-param-as-str
|
(let loop ((lst param-lst)
|
||||||
(lambda (param-lst)
|
(str ""))
|
||||||
(let loop ((lst param-lst)
|
(if (null? lst)
|
||||||
(str ""))
|
str
|
||||||
(if (null? lst)
|
(loop (cdr lst)
|
||||||
str
|
(string-append str " " (car lst))))))
|
||||||
(loop (cdr lst)
|
|
||||||
(string-append str " " (car lst)))))))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue