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