;;;;;; Strings-replace -*- Scheme -*- ;;;;;; A substring replacer for multiple parallel replacements. ;;; Taylor Campbell wrote this code; he places it in the public domain. ;;; This code depends on SRFIs 8 & 23, as well as Taylor Campbell's ;;; string collector library. ;;; (STRINGS-REPLACE ) ;;; -> string ;;; TRANSFORMATIONS -> (list-of (cons )) ;;; Transform each FROM to TO in INPUT-STRING. The transformation is ;;; strictly parallel; once a transformation from a FROM to a TO has ;;; taken place, the contents of TO in that position will never be ;;; considered as if they were in the initial INPUT-STRING. CHAR=? ;;; is used to compare characters. ;;; ;;; There is only one major shortcoming (as far as I know): it's just ;;; strings -- no regexps, no output based on input patterns, et cetera ;;; --. (define (strings-replace input replacements char=?) ;; States ought to be pooled. They're allocated and deallocated very ;; frequently during the replacing process. Perhaps pooling of them ;; could be parameterized? Neil van Dyke did that with his library ;; for calculating Levenshtein distances. ;; The OVER field of states indicates the size of the output string ;; that will be overwritten. This is necessary because some states ;; will overwrite the output string to something with a different ;; size, but other states might continue, so we need to keep track of ;; what has been overwritten. If nothing was overwritten, the OVER ;; field is just #F. (define (make-state input output) ;; Start with an index of 1, because we already tested the first ;; character; if we didn't, we'd not call MAKE-STATE. (vector input 1 output #f)) (define (state-input state) (vector-ref state 0)) (define (state-index state) (vector-ref state 1)) (define (state-output state) (vector-ref state 2)) (define (state-over state) (vector-ref state 3)) (define (step-state state) (vector (state-input state) (+ (state-index state) 1) (state-output state) (cond ((state-over state) => (lambda (over) (+ over 1))) (else #f)))) (define (state-with-over state over) (vector (state-input state) (state-index state) (state-output state) over)) (define (state-finished? state) (= (state-index state) (string-length (state-input state)))) (define (apply-state! state out-sc) (recede-string-collector! out-sc (or (state-over state) (string-length (state-input state)))) (collect-string! out-sc (state-output state))) ;; Apply a state if possible, and return a list of states that might ;; still be applicable. (define (maybe-apply-states! states out-sc) (receive (finished unfinished) (collect-finished-states states '() '()) (cond ((null? finished) states) ((null? (cdr finished)) (let ((finished-state (car finished))) (apply-state! finished-state out-sc) (collect-states-with-over states finished-state (string-length (state-output finished-state)) '()))) (else (error "More than one transformation for one input" (map (lambda (state) (list (state-input state) (state-output state))) finished)))))) (define (collect-finished-states states finished unfinished) (if (null? states) (values finished unfinished) (let ((state (car states))) (if (state-finished? state) (collect-finished-states (cdr states) (cons state finished) unfinished) (collect-finished-states (cdr states) finished (cons state unfinished)))))) ;; Update all of the states' overs to reflect BASE's new output, but ;; throw out all of those that didn't start at the same index in the ;; input string as BASE. (define (collect-states-with-over states base over states-kept) (if (null? states) states-kept (collect-states-with-over (cdr states) base over (let ((state (car states))) (if (= (state-index state) (state-index base)) (cons (state-with-over state over) states-kept) states-kept))))) (define (collect-live-states states in-char distance) (let* ((old-states (step-filtered-states states in-char '()))) (collect-new-states replacements in-char distance old-states))) ;; Kill states that can't continue, and step forward those states ;; that aren't dead yet. (define (step-filtered-states states in-char tail) (if (null? states) tail (let ((state (car states))) (step-filtered-states (cdr states) in-char (if (and (< (state-index state) (string-length (state-input state))) (char=? (string-ref (state-input state) (state-index state)) in-char)) (cons (step-state state) tail) tail))))) ;; Generate a list of the new potential states. (define (collect-new-states replacements in-char distance tail) (if (null? replacements) tail (let ((r (car replacements))) (collect-new-states (cdr replacements) in-char distance (if (and (char=? (string-ref (car r) 0) in-char) ;; This mild optimization prevents starting states ;; that would just fall off the end of the input ;; string. (<= (string-length (car r)) distance)) (cons (make-state (car r) (cdr r)) tail) tail))))) ;; Main loop. (define (loop in-index out-sc states countdown) (if (zero? countdown) (string-collector->string out-sc) (let* ((in-char (string-ref input in-index)) (live-states (collect-live-states states in-char countdown))) (collect-char! out-sc in-char) (loop (+ in-index 1) out-sc (if (null? live-states) '() ; Minor optimization here. (maybe-apply-states! live-states out-sc)) (- countdown 1))))) (loop 0 (make-string-collector) '() (string-length input)))