commander-s/scheme/layout.scm

;;seperate a long line into pieces, each fitting into a smaller line.
(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)))))

;;the result is the "answer" of scsh
(define (layout-result-standard result-str width)
  (reverse (seperate-line result-str width)))

;useful helpers
;;; EK: useful for what=
(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-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 exp)
  (let ((exp-port (open-output-string)))
    (write exp exp-port)
    (get-output-string exp-port)))

(define (sublist l pos k)
  (let ((tmp (list-tail l pos)))
    (reverse (list-tail (reverse tmp) 
			(- (length tmp) k)))))

;; crappy redrawing code

(define-record-type result-buffer :result-buffer
  (make-result-buffer line column y x num-lines num-cols highlighted marked)
  result-buffer?
  (line result-buffer-line
	set-result-buffer-line!)
  (column result-buffer-column 
	  set-result-buffer-column!)
  (y result-buffer-y set-result-buffer-y!)
  (x result-buffer-x set-result-buffer-x!)
  (num-lines result-buffer-num-lines
	     set-result-buffer-num-lines!)
  (num-cols result-buffer-num-cols
	    set-result-buffer-num-cols!)
  (highlighted result-buffer-highlighted
	       set-result-buffer-highlighted!)
  (marked result-buffer-marked
	  set-result-buffer-marked!))

;;selection of the visible area of the buffer
(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))))

(define (get-right-result-lines result-buffer text)
  (prepare-lines text 
		 (result-buffer-num-lines result-buffer)
		 (result-buffer-line result-buffer)))

;;marked and highlighted lines
(define (right-highlighted-lines result-buffer lines)
  (let ((pos-result (result-buffer-line result-buffer))
	(result-lines (result-buffer-num-lines result-buffer)))
    (let loop ((lines lines) (new '()))
      (if (null? lines)
	  new
	  (let ((el (car lines)))
	    (if (<= pos-result result-lines)
		;;auf der ersten Seite
		(loop (cdr lines)
		      (append new (list el)))
		(let* ((offset (- pos-result result-lines))
		       (new-el (- el offset)))
		  (loop (cdr lines)
			(append new (list new-el))))))))))

(define (right-marked-lines result-buffer lines)
  (let ((pos-result (result-buffer-column result-buffer))
	(result-lines (result-buffer-num-lines result-buffer))
	(marked-lines (result-buffer-marked result-buffer)))
    (let loop ((old marked-lines)
	       (new '()))
      (if (null? old)
	  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 (make-simple-result-buffer-printer 
	 pos-y pos-x text highlighted-lines marked-lines)
  (lambda (window result-buffer result-buffer-has-focus?)

    (set-result-buffer-y! result-buffer pos-y)
    (set-result-buffer-column! result-buffer pos-x)
    (set-result-buffer-highlighted! result-buffer
				    highlighted-lines)
    (set-result-buffer-marked! result-buffer
			       marked-lines)
    (set-result-buffer-highlighted! 
     result-buffer (right-highlighted-lines result-buffer text))
    (set-result-buffer-marked!
     result-buffer (right-marked-lines result-buffer text))

    (let ((lines (get-right-result-lines result-buffer text))
	  (result-lines (result-buffer-num-lines result-buffer))
	  (result-cols (result-buffer-num-cols result-buffer)))
      
      (let loop ((pos 1))
	(if (> pos result-lines)
	    (values)
	    (let* ((line (list-ref lines (- pos 1)))
		   (fitting-line
		    (if (> (string-length line) result-cols)
			(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 result-buffer-has-focus?
		       (member pos highlighted-lines))
		  (begin
		    (wattron window (A-REVERSE))
		    (mvwaddstr window pos 1 line)
		    (wattrset window (A-NORMAL))
		    (loop (+ pos 1)))
		  (if (member pos marked-lines)
		      (begin
			(wattron window (A-BOLD))
			(mvwaddstr window pos 1 line)
			(wattrset window (A-NORMAL))
			(loop (+ pos 1)))
		      (begin
			(mvwaddstr window pos 1 line)
			(loop (+ pos 1)))))))))))

(define (fill-up-string length string)
  (if (> (string-length string) length)
      (substring string 0 length)
      (string-append
       string (make-string (- length (string-length string))
			   #\space))))

(define (cut-to-size length string)
  (if (> (string-length string) length)
      (substring string 0 length)
      string))

;; ,open let-opt
(define (wait-for-key . optionals)
  (let-optionals optionals
      ((tty-port (current-input-port)))
    (let* ((old (tty-info tty-port))
	   (copy (copy-tty-info old)))
      (set-tty-info:local-flags 
       copy
       (bitwise-and (tty-info:local-flags copy)
		    (bitwise-not ttyl/canonical)))
      (set-tty-info:min copy 1)
      (set-tty-info:time copy 0)
      (set-tty-info/now tty-port copy)
      (let ((c (read-char tty-port)))
	(set-tty-info/now tty-port old)
	c))))

(define (show-shell-screen)
  (def-prog-mode)
  (endwin)
  (display "Press any key to return to Commander S")
  (wait-for-key))

(define (with-output-to-result-screen thunk)
  (def-prog-mode)
  (endwin)
  (newline)
  (thunk)
  (display "Press any key to return to Commander S...")
  (wait-for-key))

(define paint-lock (make-lock))