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

First try to split up PAINT into multiple functions, thus, allowing to 

repaint only parts of the screen. However, this commit introduces some
funny display bugs. ;-)
This commit is contained in:
eknauel 2005-05-10 19:37:54 +00:00
parent 599021b937
commit 2353335d5e
1 changed files with 321 additions and 340 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

661
scheme/nuit-engine.scm
View File

@ -12,13 +12,19 @@
;;************************************************************************* ;;*************************************************************************
;;State ;;State
;;The different windows (define-record-type app-window :app-window
;;------------------------ (make-app-window x y width height curses-win)
(define bar1) app-window?
(define bar2) (x app-window-x)
(define bar3) (y app-window-y)
(define command-win) (width app-window-width)
(define result-win) (height app-window-height)
(curses-win app-window-curses-win set-app-window-curses-win!))
(define bar-1 #f)
(define bar-2 #f)
(define command-window #f)
(define result-window #f)
(define shortcuts '("F1:Exit" (define shortcuts '("F1:Exit"
"F2:Repaint (after change of buffer size)" "F2:Repaint (after change of buffer size)"
@ -224,320 +230,299 @@
;;Actions ;;Actions
;;start the whole thing ;;start the whole thing
(define nuit (define (nuit)
(lambda () (run))
(run)))
;;handle input ;;handle input
(define run (define (run)
(lambda ()
(begin
;;initialisation '(set-interrupt-handler interrupt/keyboard
(init-screen) (lambda a
(set! bar1 (newwin 0 0 0 0)) (set! active-keyboard-interrupt a)))
(set! bar2 (newwin 0 0 0 0))
(set! bar3 (newwin 0 0 0 0))
(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 ;;Loop
(paint) (paint)
(let loop ((ch (wait-for-input))) (let loop ((ch (wait-for-input)))
(cond (cond
;;The result of pressing these keys is independent of which
;;The result of pressing these keys is independent of which ;;Buffer is active
;;Buffer is active ;;Finish
;;Finish ((= ch key-f1)
((= ch key-f1) (begin
(begin (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) (restore-state))
(restore-state)) (endwin)
(endwin) (display "")))
(display "")))
((= ch key-f2)
(endwin)
(run))
((= ch key-f2) ;;Ctrl-x -> wait for next input
(endwin) ((= ch 24)
(run)) (begin
(set! c-x-pressed (not c-x-pressed))
(if (= active-buffer 2)
(let ((key-message
(make-key-pressed-message active-command
current-result-object
ch)))
(set! current-result-object (switch key-message))))
(paint)
(loop (wait-for-input))))
;;Ctrl-x -> wait for next input ;; forward in result history
((= ch 24) ((= ch key-npage)
(begin (history-forward)
(set! c-x-pressed (not c-x-pressed)) (paint-result-window)
(if (= active-buffer 2) (loop (wait-for-input)))
(let ((key-message
(make-key-pressed-message active-command ;; back in result history
current-result-object ((= ch key-ppage)
ch))) (history-back)
(set! current-result-object (switch key-message)))) (paint-result-window)
(paint) (loop (wait-for-input)))
(loop (wait-for-input))))
;; forward in result history ;;if lower window is active a message is sent.
((= ch key-npage) (else
(history-forward) (if c-x-pressed
(print-result-buffer result-win) (cond
(loop (wait-for-input)))
;;Ctrl-x o ->switch buffer
;; back in result history ((= ch 111)
((= ch key-ppage) (begin
(history-back) (if (= active-buffer 1)
(print-result-buffer result-win) (begin
(loop (wait-for-input))) (set! active-buffer 2)
(let ((key-message
(make-key-pressed-message active-command
;;if lower window is active a message is sent.
(else
(if c-x-pressed
(cond
;;Ctrl-x o ->switch buffer
((= ch 111)
(begin
(if (= active-buffer 1)
(begin
(set! active-buffer 2)
(let ((key-message
(make-key-pressed-message active-command
current-result-object current-result-object
97))) 97)))
(set! current-result-object (switch key-message)))) (set! current-result-object (switch key-message))))
(set! active-buffer 1)) (set! active-buffer 1))
(set! c-x-pressed #f) (set! c-x-pressed #f)
(loop (wait-for-input)))) (loop (wait-for-input))))
;;C-x r -> redo ;;C-x r -> redo
((= ch 114) ((= ch 114)
(if (or (> (length text-command) 2) (if (or (> (length text-command) 2)
(not (equal? active-command ""))) (not (equal? active-command "")))
(let ((command-string (string-append active-command (let ((command-string (string-append active-command
active-parameters)) active-parameters))
(text (sublist text-command 0 (text (sublist text-command 0
(- (length text-command) 1)))) (- (length text-command) 1))))
(begin (begin
(switch restore-message) (switch restore-message)
(set! text-command (append text (set! text-command (append text
(list command-string))) (list command-string)))
(execute-command) (execute-command)
(set! command-history-pos (- (length text-command) 1)) (set! command-history-pos (- (length text-command) 1))
(set! c-x-pressed #f) (set! c-x-pressed #f)
(endwin) (endwin)
(run))) (run)))
(begin
(set! c-x-pressed #f)
(loop (wait-for-input)))))
(else
(begin (begin
(if (= active-buffer 2)
(let ((key-message
(make-key-pressed-message active-command
current-result-object
ch)))
(set! current-result-object (switch key-message)))
(if (= ch 115)
(let* ((message
(make-selection-message
active-command current-result-object))
(marked-items (switch message)))
(add-string-to-command-buffer marked-items))))
(set! c-x-pressed #f) (set! c-x-pressed #f)
(loop (wait-for-input))))) (loop (wait-for-input)))))
(else
(begin
(if (= active-buffer 2) (if (= active-buffer 2)
(let ((key-message (let ((key-message
(make-key-pressed-message active-command (make-key-pressed-message active-command
current-result-object current-result-object
ch))) ch)))
(begin (set! current-result-object (switch key-message)))
(set! current-result-object (switch key-message))
(loop (wait-for-input))))
(cond (if (= ch 115)
(let* ((message
;;Enter (make-selection-message
((= ch 10) active-command current-result-object))
(let ((restore-message (make-restore-message (marked-items (switch message)))
active-command (add-string-to-command-buffer marked-items))))
current-result-object))) (set! c-x-pressed #f)
(begin (loop (wait-for-input)))))
(switch restore-message)
(execute-command) (if (= active-buffer 2)
(set! command-history-pos (- (length text-command) 1)) (let ((key-message
(make-key-pressed-message active-command
current-result-object
ch)))
(begin
(set! current-result-object (switch key-message))
(loop (wait-for-input))))
(cond
;;Enter
((= ch 10)
(let ((restore-message (make-restore-message
active-command
current-result-object)))
(begin
(switch restore-message)
(execute-command)
(set! command-history-pos (- (length text-command) 1))
;(loop (paint)))) ;(loop (paint))))
(endwin) (endwin)
(run)))) (run))))
;;Ctrl+p -> History back
; ((= ch 16)
; (begin
; (history-back)
; (loop (paint))))
; ;;Ctrl+n -> History forward
; ((= ch 14)
; (begin
; (history-forward)
; (loop (paint))))
; ;;Ctrl+s -> get selection (else
; ((= ch 19) (begin
; (let* ((message (make-selection-message active-command (set! command-buffer (make-buffer text-command
; current-result-object)) pos-command
; (marked-items (switch message))) pos-command-col
; (begin pos-command-fin-ln
; (add-string-to-command-buffer marked-items) command-buffer-pos-y
; (loop (paint))))) command-buffer-pos-x
command-lines
(else command-cols
can-write-command
command-history-pos))
(set! command-buffer (input command-buffer ch))
(let ((text (buffer-text command-buffer))
(pos-line (buffer-pos-line command-buffer))
(pos-col (buffer-pos-col command-buffer))
(pos-fin-ln (buffer-pos-fin-ln command-buffer))
(pos-y (buffer-pos-y command-buffer))
(pos-x (buffer-pos-x command-buffer))
(num-lines (buffer-num-lines command-buffer))
(num-cols (buffer-num-cols command-buffer))
(can-write (buffer-can-write command-buffer))
(history-pos (buffer-history-pos command-buffer)))
(begin (begin
(set! command-buffer (make-buffer text-command (set! text-command text)
pos-command (set! pos-command pos-line)
pos-command-col (set! pos-command-col pos-col)
pos-command-fin-ln (set! pos-command-fin-ln pos-fin-ln)
command-buffer-pos-y (set! command-buffer-pos-y pos-y)
command-buffer-pos-x (set! command-buffer-pos-x pos-x)
command-lines (set! command-lines num-lines)
command-cols (set! command-cols num-cols)
can-write-command (set! can-write-command can-write)
command-history-pos)) (set! command-history-pos history-pos)))
(set! command-buffer (input command-buffer ch)) (paint-command-window-contents)
(let ((text (buffer-text command-buffer)) (loop (wait-for-input)))))))))))
(pos-line (buffer-pos-line command-buffer))
(pos-col (buffer-pos-col command-buffer))
(pos-fin-ln (buffer-pos-fin-ln command-buffer))
(pos-y (buffer-pos-y command-buffer))
(pos-x (buffer-pos-x command-buffer))
(num-lines (buffer-num-lines command-buffer))
(num-cols (buffer-num-cols command-buffer))
(can-write (buffer-can-write command-buffer))
(history-pos (buffer-history-pos command-buffer)))
(begin
(set! text-command text)
(set! pos-command pos-line)
(set! pos-command-col pos-col)
(set! pos-command-fin-ln pos-fin-ln)
(set! command-buffer-pos-y pos-y)
(set! command-buffer-pos-x pos-x)
(set! command-lines num-lines)
(set! command-cols num-cols)
(set! can-write-command can-write)
(set! command-history-pos history-pos)))
(paint)
(loop (wait-for-input)))))))))))))
;;print and wait for input (define (window-init-curses-win! window)
(define (paint) (set-app-window-curses-win!
window
(newwin (app-window-height window) (app-window-width window)
(app-window-y window) (app-window-x window))))
(define (init-windows!)
(init-screen) (init-screen)
(let* ((bar1-y 1) (set! bar-1
(bar1-x 1) (make-app-window 1 1
(bar1-h 2) (- (COLS) 2) 2
(bar1-w (- (COLS) 2)) #f))
(bar2-y (+ (round (/ (LINES) 3)) 2)) (set! bar-2
(bar2-x 1) (make-app-window 1 (+ (round (/ (LINES) 3)) 2)
(bar2-h 3) (- (COLS) 2) 3
(bar2-w (- (COLS) 2)) #f))
(comwin-y 2) (set! command-window
(comwin-x 1) (make-app-window 1 2
(comwin-h (- bar2-y 2)) (- (COLS) 2) (- (app-window-y bar-2) 2)
(comwin-w (- (COLS) 2)) #f))
(reswin-y (+ bar2-y 3)) (set! result-window
(reswin-x 1) (make-app-window 1 (+ (app-window-y bar-2) 3)
(reswin-h (- (- (LINES) 6) comwin-h)) (- (COLS) 2)
(reswin-w (- (COLS) 2))) (- (- (LINES) 6) (app-window-height command-window))
#f))
(window-init-curses-win! bar-1)
(window-init-curses-win! bar-2)
(window-init-curses-win! command-window)
(window-init-curses-win! result-window)
(wclear (app-window-curses-win bar-1))
(wclear (app-window-curses-win bar-2))
(wclear (app-window-curses-win command-window))
(wclear (app-window-curses-win result-window))
(clear))
(wclear bar1) (define (paint-bar-1)
(wclear bar2) (mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
(wclear command-win) (wrefresh (app-window-curses-win bar-1)))
(wclear result-win)
(clear)
(set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x)) (define (paint-bar-2)
(set! bar2 (newwin bar2-h bar2-w bar2-y bar2-x)) (box (app-window-curses-win bar-2) (ascii->char 0) (ascii->char 0))
(set! command-win (newwin comwin-h comwin-w comwin-y comwin-x)) (print-active-command-win (app-window-curses-win bar-2)
(set! result-win (newwin reswin-h reswin-w reswin-y reswin-x)) (app-window-width bar-2)))
;(box standard-screen (ascii->char 0) (ascii->char 0))
;(refresh)
(mvwaddstr bar1 0 1 "SCSH-NUIT")
(wrefresh bar1)
(box bar2 (ascii->char 0) (ascii->char 0)) (define (paint-command-window)
(print-active-command-win bar2 bar2-w) (box (app-window-curses-win command-window)
(ascii->char 0) (ascii->char 0)))
(box command-win (ascii->char 0) (ascii->char 0)) (define (paint-command-window-contents)
(set! command-lines (- comwin-h 2)) (set! command-lines (- (app-window-height command-window) 2))
(set! command-cols (- comwin-w 3)) (set! command-cols (- (app-window-width command-window) 3))
(set! command-buffer
(set! command-buffer (make-buffer text-command (make-buffer text-command
pos-command pos-command
pos-command-col pos-command-col
pos-command-fin-ln pos-command-fin-ln
command-buffer-pos-y command-buffer-pos-y
command-buffer-pos-x command-buffer-pos-x
command-lines command-lines
command-cols command-cols
can-write-command can-write-command
command-history-pos)) command-history-pos))
(set! command-buffer
(set! command-buffer (print-command-buffer command-win command-buffer)) (print-command-buffer (app-window-curses-win command-window)
command-buffer))
(wrefresh (app-window-curses-win command-window)))
(wrefresh command-win) (define (paint-result-window)
(box result-win (ascii->char 0) (ascii->char 0)) (wclear (app-window-curses-win result-window))
(set! result-lines (- reswin-h 2)) (box (app-window-curses-win result-window)
(set! result-cols (- reswin-w 3)) (ascii->char 0) (ascii->char 0))
(print-result-buffer result-win) (set! result-lines (- (app-window-height result-window) 2))
(wrefresh result-win) (set! result-cols (- (app-window-width result-window) 3))
(print-result-buffer result-window)
(set! command-buffer (cur-right-pos command-win result-win comwin-h (wrefresh (app-window-curses-win result-window)))
reswin-h command-buffer))
(let ((text (buffer-text command-buffer)) (define (paint)
(pos-line (buffer-pos-line command-buffer)) (init-windows!)
(pos-col (buffer-pos-col command-buffer)) (paint-bar-1)
(pos-fin-ln (buffer-pos-fin-ln command-buffer)) (paint-bar-2)
(pos-y (buffer-pos-y command-buffer)) (paint-command-window)
(pos-x (buffer-pos-x command-buffer)) (paint-command-window-contents)
(num-lines (buffer-num-lines command-buffer)) (paint-result-window)
(num-cols (buffer-num-cols command-buffer))
(can-write (buffer-can-write command-buffer)) (set! command-buffer
(history-pos (buffer-history-pos command-buffer))) (cur-right-pos (app-window-curses-win command-window)
(begin (app-window-curses-win result-window)
(set! text-command text) (app-window-height command-window)
(set! pos-command pos-line) (app-window-height result-window)
(set! pos-command-col pos-col) command-buffer))
(set! pos-command-fin-ln pos-fin-ln)
(set! command-buffer-pos-y pos-y)
(set! command-buffer-pos-x pos-x)
(set! command-lines num-lines)
(set! command-cols num-cols)
(set! can-write-command can-write)
(set! command-history-pos history-pos)))
;(refresh) (let ((text (buffer-text command-buffer))
; (wrefresh command-win) (pos-line (buffer-pos-line command-buffer))
; (wrefresh result-win) (pos-col (buffer-pos-col command-buffer))
; (wrefresh bar1) (pos-fin-ln (buffer-pos-fin-ln command-buffer))
; (wrefresh bar2) (pos-y (buffer-pos-y command-buffer))
)) (pos-x (buffer-pos-x command-buffer))
(num-lines (buffer-num-lines command-buffer))
(num-cols (buffer-num-cols command-buffer))
(can-write (buffer-can-write command-buffer))
(history-pos (buffer-history-pos command-buffer)))
(set! text-command text)
(set! pos-command pos-line)
(set! pos-command-col pos-col)
(set! pos-command-fin-ln pos-fin-ln)
(set! command-buffer-pos-y pos-y)
(set! command-buffer-pos-x pos-x)
(set! command-lines num-lines)
(set! command-cols num-cols)
(set! can-write-command can-write)
(set! command-history-pos history-pos)))
(define (wait-for-input) (define (wait-for-input)
(noecho) (noecho)
(keypad bar1 #t) (keypad (app-window-curses-win bar-1) #t)
(set! active-keyboard-interrupt #f) (set! active-keyboard-interrupt #f)
(let ((ch (wgetch bar1))) (let ((ch (wgetch (app-window-curses-win bar-1))))
(echo) (echo)
ch)) ch))
@ -771,65 +756,64 @@
;;print the lower window ;;print the lower window
(define print-result-buffer (define (print-result-buffer result-window)
(lambda (reswin) (let* ((window (app-window-curses-win result-window))
(let* ((print-message (make-print-message active-command (print-message (make-print-message active-command
current-result-object current-result-object
command-cols)) 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))
(pos-x (print-object-pos-x model)) (pos-x (print-object-pos-x model))
(highlighted-lns (print-object-highlighted-lines model)) (highlighted-lns (print-object-highlighted-lines model))
(marked-lns (print-object-marked-lines model))) (marked-lns (print-object-marked-lines model)))
(begin (set! text-result text)
(set! text-result text) (set! pos-result pos-y)
(set! pos-result pos-y) (set! pos-result-col pos-x)
(set! pos-result-col pos-x) (set! highlighted-lines highlighted-lns)
(set! highlighted-lines highlighted-lns) (set! marked-lines marked-lns)
(set! marked-lines marked-lns) (right-highlighted-lines)
(right-highlighted-lines) (right-marked-lines)
(right-marked-lines) (let ((lines (get-right-result-lines)))
(let ((lines (get-right-result-lines))) (let loop ((pos 1))
(let loop ((pos 1)) (if (> pos result-lines)
(if (> pos result-lines) values
values (let ((line (list-ref lines (- pos 1))))
(let ((line (list-ref lines (- pos 1)))) (begin
(begin (if (not (standard-result-obj? current-result-object))
(if (not (standard-result-obj? current-result-object)) (set! line
(set! line (if (> (string-length line) result-cols)
(if (> (string-length line) result-cols) (let ((start-line
(let ((start-line (substring line 0
(substring line 0 (- (ceiling (/ result-cols 2))
(- (ceiling (/ result-cols 2)) 3)))
3))) (end-line
(end-line (substring line
(substring line (- (string-length line)
(- (string-length line) (ceiling
(ceiling (/ result-cols 2)))
(/ result-cols 2))) (string-length line))))
(string-length line)))) (string-append start-line "..." end-line))
(string-append start-line "..." end-line)) line)))
line))) (if (and (member pos highlighted-lines)
(if (and (member pos highlighted-lines) (= active-buffer 2))
(= active-buffer 2)) (begin
(wattron window (A-REVERSE))
(mvwaddstr window pos 1 line)
(wattrset window (A-NORMAL))
(wrefresh window)
(loop (+ pos 1)))
(if (member pos marked-lines)
(begin (begin
(wattron reswin (A-REVERSE)) (wattron window (A-BOLD))
(mvwaddstr reswin pos 1 line) (mvwaddstr window pos 1 line)
(wattrset reswin (A-NORMAL)) (wattrset window (A-NORMAL))
(wrefresh reswin) (wrefresh window)
(loop (+ pos 1))) (loop (+ pos 1)))
(if (member pos marked-lines) (begin
(begin (mvwaddstr window pos 1 line)
(wattron reswin (A-BOLD)) (wrefresh window)
(mvwaddstr reswin pos 1 line) (loop (+ pos 1))))))))))))
(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
@ -1176,6 +1160,3 @@
str str
(loop (cdr lst) (loop (cdr lst)
(string-append str " " (car lst))))))) (string-append str " " (car lst)))))))