;FILE		"tabs.scm"
;IMPLEMENTS	Tabifaction.
;AUTHOR		Ken Dickey
;DATE		1991 December 19
;LAST UPDATED	1991 December 28

;NOTES:		Requires string ports (not standard; should be).
;
;		There are a number of optimizations which could be
;		made here if you want to speed things up.
;
;		String ports are a pain to simulate (see FORMAT), beat 
;		on your implementor if you don't have 'em.

;; Interface:
;;
;; (STRING-ENTAB <string> <chars-per-tab> . <output-port>)
;;
;; (STRING-DETAB <string> <chars-per-tab> . <output-port>)
;;
;; These functions convert tabs to blanks (detab) or blanks to tabs
;; (entab).  If <output-port> is used, it has the same convention
;; as the port argument to FORMAT: #t => current-output-port, #f =>
;; return a new string, else the argument is an output port to be
;; used.


;; tab character is implementation dependent

(define TAB-CHARACTER (integer->char 9)) ; ASCII horizontal-tab

(define DONT-PRINT (string->symbol "")) ;; your mileage may vary



;;; tab expansion for non-null strings: tab -> repeated blanks

(define (STRING-DETAB <string> <chars-per-tab> . <optional-port>)

  (let ( (OUTP (rest-arg->output-port <optional-port>))
	 (INDEX-BOUND (string-length <string>))
	 (SPACES
	   (lambda (how-many port)
	    (let loop ( (n 0) )
	     (cond
	       ((< n how-many)
	        (display #\space port)
	        (loop (+ n 1)))
	 ) )))
       )
    (let loop ( (index 0) (outpos 0) )
      (cond
       ((< index index-bound)
	(let ( (c (string-ref <string> index)) )
	  (cond
	     ((eqv? c tab-character)  ;; N.B.: eq? is not guarenteed on characters
	      (let ( (num-spaces (- <chars-per-tab>
	 			    (modulo outpos <chars-per-tab>)) )
		   )
	        (spaces num-spaces outp)
	        (loop (+ index 1) (+ outpos num-spaces)) )
             )
	     (else
	       (write-char c outp)
	       (loop (+ index 1) (+ outpos 1)) )
       )) )
       (else ;; processing done; give result
	 (if (output-string-port? outp)
	     (get-output-string outp)
	     dont-print)
       ) )
) ) )


;;; tab compression: repeated blanks -> tab

(define (STRING-ENTAB <string> <chars-per-tab> . <optional-port>)

  (letrec
       ( (OUTP     (rest-arg->output-port <optional-port>) )
	 (STR-LEN  (string-length <string>) )
	 (OUTSLICE ; output string slice from start thru end
	   (lambda (start end)
	     (let out-loop ( (i start) )
	       (cond
		 ((<= i end)
		  (write-char (string-ref <string> i) outp)
		  (out-loop (+ i 1))
	       ) )
	 ) ) )
	 (PROCESS-SLICE ; process string slice between tab stops
	   (lambda (start end)
	     ; loop backward from tab stop while blanks
	     (let loop ( (index (- end 1)) )
	       (cond
		 ((and (<= start index)
		       (char=? #\space (string-ref <string> index)))
		  (loop (- index 1))
		 )
		 (else ; processing complete; output it
		  (outslice start index)
		  (if (< index (- end 1))
		      (write-char tab-character outp) )
	     ) ) )
	 ) )
       )
    ; process each tab-stop sized slice of the string

    (let ( (num-slices (quotient str-len <chars-per-tab>)) )

      (let slice-loop ( (index 0) (slice 0) )
	(cond
	  ((< slice num-slices)
	   (process-slice index (+ index <chars-per-tab>))
	   (slice-loop (+ index <chars-per-tab>) (+ slice 1))
	  )
	  (else ; process tail (too short for slice)
	    (outslice index (- str-len 1))
	    ; the result
	    (if (output-string-port? outp)
	    	(get-output-string outp)
		dont-print)
	) )
    ) )
) )


(define (REST-ARG->OUTPUT-PORT arg)
;
; arg is '() or '(#t) or '(#f) or '(<#port>)
; '() defaults to current output port
; #t => current output port
; #f => string return
; <#port> => use this output port
;
  (cond
    ((null? arg) (current-output-port))
    ((output-port? (car arg)) (car arg))
    ((eq? (car arg) #t)  (current-output-port))
    ((eq? (car arg) #f)  (open-output-string))
    (else (error "Bad port argument: " (car arg)))
) )


;;
;; Simple test code
;;
;
;(define (TEST-ENTAB s cpt) 
;  (print-tab-ruler cpt)
;  (newline)
;  (string-entab s cpt)
;  (newline))
;
;(define (TEST-DETAB s cpt) 
;  (print-tab-ruler cpt) 
;  (newline) 
;  (string-detab s cpt) 
;  (newline))
;
;(define (PRINT-RULER . port)
;  (let ( (outp (if (null? port) (current-output-port) (cdr port))) )
;    (newline outp)
;    (let loop ( (col 1) )
;      (display (modulo col 9) outp) ;; base 10 ruler
;      (if (< col 77) ;; max-col
;	  (loop (+ col 1)))
;) ) )
;
;(define (PRINT-TAB-RULER  chars-per-tab . port)
;  (let ( (outp (if (null? port) (current-output-port) (cdr port))) )
;    (newline outp)
;    (let loop ( (col 1) )
;      (display (modulo col chars-per-tab) outp)
;      (if (< col 77) ;; max-col
;	  (loop (+ col 1)))
;) ) )
;
;
;; Get a line from a port & return it as a string.
;; Return the eof-object on eof.
;
;(define (GET-LINE input-port) 
;  (let ( (line-buf (open-output-string)) )
;    (let loop ( (c (peek-char input-port)) )
;      (cond
;	 ((eof-object? c)
;	  (let ( (line (get-output-string line-buf)) )
;	    (if (> (string-length line) 0)
;	    	line
;		c) ;; the eof-object
;	 ))
;	 ((eqv? c #\newline)  ; hack this for ms-dos style files
;	  (read-char p) ; consume newline
;	  (get-output-string line-buf) ; return the string
;	 )
;	 (else
;	   (write-char (read-char input-port) line-buf)
;	   (loop (peek-char c))
;      ) )
;) ) )

;; for Gambit 1.71

(define (OUTPUT-STRING-PORT? p)
  (and (output-port? p) 
       (eq? (##vector-ref p 1) 'string) ;; (eq? (port-name p) 'string)
) )

;;			--- E O F ---