commander-s/scheme/win.scm

(define-record-type app-window :app-window
  (make-app-window x y width height curses-win)
  app-window?
  (x app-window-x)
  (y app-window-y)
  (width app-window-width)
  (height app-window-height)
  (curses-win app-window-curses-win set-app-window-curses-win!))

(define-record-discloser :app-window
  (lambda (rec)
    `(app-window 
      (x ,(app-window-x rec)) (y ,(app-window-y rec))
      (w ,(app-window-width rec)) (h ,(app-window-height rec)))))

(define *bar-1* #f)
(define (bar-1) *bar-1*)

(define *active-command-window* #f)
(define (active-command-window) *active-command-window*)

(define *command-frame-window* #f)
(define (command-frame-window) *command-frame-window*)

(define *command-window* #f)
(define (command-window) *command-window*)

(define *result-window* #f)
(define (result-window) *result-window*)

(define *result-frame-window* #f)
(define (result-frame-window) *result-frame-window*)

(define *command-buffer*
  (make-buffer '("Welcome to the Commander S!" "")
	       2 2 2 1 1
	       0 0
	       #t 1))

(define (command-buffer) *command-buffer*)

(define *result-buffer*
  (make-result-buffer 0 0 0 0
		      #f #f ; set in INIT-WINDOWS
		      '() '()))

(define (result-buffer) *result-buffer*)

(define *focus-buffer* 'command-buffer)

(define (focus-on-command-buffer?)
  (eq? *focus-buffer* 'command-buffer))

(define (focus-command-buffer!)
  (set! *focus-buffer* 'command-buffer))

(define (focus-on-result-buffer?)
  (eq? *focus-buffer* 'result-buffer))

(define (focus-result-buffer!)
  (set! *focus-buffer* 'result-buffer))

(define *untouched-tty* #f)

(define (save-initial-tty-info! port)
  (set! *untouched-tty* (copy-tty-info (tty-info port))))

(define (restore-initial-tty-info! port)
  (set-tty-info/now port *untouched-tty*))

(define (make-inlying-app-window outer-window)
  (make-app-window (+ (app-window-x outer-window) 1)
		   (+ (app-window-y outer-window) 1)
		   (- (app-window-width outer-window) 2)
		   (- (app-window-height outer-window) 2)
		   #f))

(define (window-init-curses-win! window)
  (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!)
  (set! *bar-1*
	(make-app-window 1 1 
			 (- (COLS) 2) 2 
			 #f))
  (set! *active-command-window*
	(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
			 (- (COLS) 2) 3
			 #f))
  (set! *command-frame-window*
	(make-app-window 1 2
			 (- (COLS) 2) (- (app-window-y (active-command-window)) 2)
			 #f))
  (set! *command-window*
	(make-inlying-app-window (command-frame-window)))
  (set! *result-frame-window*
	(make-app-window 1 (+ (app-window-y (active-command-window)) 3)
			 (- (COLS) 2)
			 (- (- (LINES) 6) (app-window-height (command-frame-window)))
			 #f))
  (set! *result-window*
	(make-inlying-app-window (result-frame-window)))

  (let ((all-windows 
	 (list (bar-1) (active-command-window)
	       (command-frame-window) (command-window)
	       (result-frame-window) (result-window))))
    (for-each window-init-curses-win! all-windows)

    (set-result-buffer-num-lines! 
     *result-buffer* (- (app-window-height (result-window)) 2))
    (set-result-buffer-num-cols!
     *result-buffer* (- (app-window-width (result-window)) 3))
  
    (for-each wclear 
	      (map app-window-curses-win all-windows))))

;; result-buffer-object-change-channel

(define result-buffer-changed-channel
  (make-channel))

(define result-buffer-changes-subscribers
  (make-channel))

(define (signal-result-buffer-object-change)
  (debug-message "signal-result-buffer-object-change")
  (send result-buffer-changed-channel 'ignore))

(define (spawn-result-buffer-surveillant)
  (spawn
   (lambda ()
     (let lp ()
       (select
	(wrap (receive-rv result-buffer-changes-subscribers)
	      (lambda (answer-channel)
		(debug-message "result-buffer-surveillant 1")
		(receive result-buffer-changed-channel)
		(send answer-channel 'ignore)
		(lp)))
	(wrap (receive-rv result-buffer-changed-channel)
	      (lambda (ignore)
		(debug-message "result-buffer-surveillant 2")
		(lp))))))))
      
(define (result-buffer-other-object-has-focus-rv)
  (let ((answer-channel (make-channel)))
    (send result-buffer-changes-subscribers answer-channel)
    (receive-rv answer-channel)))

(spawn-result-buffer-surveillant)