; -*- Scheme -*-
;
; $Id: string30.scm,v 1.1 1998/03/16 07:59:48 foner Exp $

(require 'char-set:member?)

;+doc
; procedure: substring:find-balanced-chars
; arguments: source start end left-chars mid-chars right-chars
;            if-found if-not-found state
; signature: forall a => string x int x int x char-set x char-set x
;                        char-set x (int x (a -> a) a -> a) x (a -> a) -> a
; pre:       (and (<= 0 start end (string-length source)))
;
; SOURCE is searched in order for any MID-CHARS which are bracketed by
; LEFT-CHARS and RIGHT-CHARS.  IF-FOUND is called with the position of
; the character, a continuation which if invoked will find the
; position of succeeding satisfying characters and the STATE.
; IF-NOT-FOUND is called when the end of SOURCE is reached.
;
; This is an implementation of the Icon function `bal(c1, c2, c3, s, i, j)'
; The Icon book claims that this function is "... useful in
; applications thta involve the analysis of formulas, expressions and
; other strings that have balanced bracketing characters".  I can't
; think that I've ever wanted to use it, but for completeness' sake
; I've included it here. 
;
; The function has so many parameters that I doubt you would want to
; call it directly.  Just decide what arguments you really want and
; wrap all the rest up in a function with another name.
;
; XXX Currently generates a position even if the right bracket is not there!
; XXX Since this code has been available over a year and nobody has
; XXX complained about this I guess that this is not a frequently used
; XXX function :-)
;-doc

(define substring:find-balanced-chars
  (lambda (s ss se lcs mcs rcs if-found if-not-found st)
    (let loop ((cp ss) (nl 0) (nst st))
      (if (>= cp se)
	(if-not-found nst)
	(let ((cc (string-ref s cp)))
	  (cond
	    ((char-set:member? mcs cc)
	       (let ((np (lambda (r) (loop (+ 1 cp) nl r))))
		 (if (zero? nl) (if-found cp np nst) (np nst))))
	    ((char-set:member? lcs cc) (loop (+ cp 1) (+ nl 1) nst))
	    ((char-set:member? rcs cc) (loop (+ cp 1) (- nl 1) nst))
	    (else (loop (+ 1 cp) nl nst))))))))

; eof
