;; $Id: dblib.dsl 0.91 1997/08/28 14:09:41 nwalsh Exp $
;;
;; Library functions that I haven't found a better place for...
;; ======================================================================

(define (match-split string target)
  (let loop ((result '()) (current "") (rest string))
    (if (< (string-length rest) (string-length target))
	(append result (if (equal? (string-append current rest) "")
				  '()
				  (list (string-append current rest))))
	(if (equal? target (substring rest 0 (string-length target)))
	    (loop (append result 
			  (if (equal? current "")
			      '()
			      (list current))
			  (list target))
		  ""
		  (substring rest (string-length target) (string-length rest)))
	    (loop result
		  (string-append current (substring rest 0 1))
		  (substring rest 1 (string-length rest)))))))

(define (match-split-string-list string-list target)
  (let loop ((result '()) (sl string-list))
    (if (null? sl)
	result
	(loop (append result (match-split (car sl) target))
	      (cdr sl)))))

(define (match-split-list string target-list)
  (let loop ((result (list string)) (tlist target-list))
    (if (null? tlist)
	result
	(loop (match-split-string-list result (car tlist))
	      (cdr tlist)))))

;; ======================================================================

(define (assoc-objs alist)
  (let loop ((result '()) (al alist))
    (if (null? al)
	result
	(loop (append result (list (car (car al)))) (cdr al)))))

(define (assoc obj alist)
  (let loop ((al alist))
    (if (null? al)
	#f
	(if (equal? obj (car (car al)))
	    (car al)
	    (loop (cdr al))))))

(define (match-substitute-sosofo string assoc-list)
  (if (assoc string assoc-list)
      (car (cdr (assoc string assoc-list)))
      (literal string)))

(define (string-list-sosofo string-list assoc-list)
  (if (null? string-list)
      (empty-sosofo)
      (sosofo-append (match-substitute-sosofo (car string-list) assoc-list)
		     (string-list-sosofo (cdr string-list) assoc-list))))

;; ======================================================================

(define (repl-substring? string target pos)
  (let* ((could-match (<= (+ pos (string-length target)) 
			 (string-length string)))
	 (match (if could-match 
		    (substring string pos (+ pos (string-length target))) "")))
    (and could-match (string=? match target))))

(define (repl-substring string target repl pos)
  (let ((matches (repl-substring? string target pos)))
    (if matches
	(string-append
	 (substring string 0 pos)
	 repl
	 (substring string 
		    (+ pos (string-length target)) 
		    (string-length string)))
	string)))

(define (repl-substring-list? string replace-list pos)
  (let loop ((list replace-list))
    (let ((target (car list))
	  (repl   (car (cdr list)))
	  (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
	  #t
	  (if (null? rest)
	      #f
	      (loop rest))))))

(define (repl-substring-list-target string replace-list pos)
  (let loop ((list replace-list))
    (let ((target (car list))
	  (repl   (car (cdr list)))
	  (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
	  target
	  (if (null? rest)
	      #f
	      (loop rest))))))

(define (repl-substring-list-repl string replace-list pos)
  (let loop ((list replace-list))
    (let ((target (car list))
	  (repl   (car (cdr list)))
	  (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
	  repl
	  (if (null? rest)
	      #f
	      (loop rest))))))

(define (repl-substring-list string replace-list pos)
  (if (repl-substring-list? string replace-list pos)
      (let ((target (repl-substring-list-target string replace-list pos))
	    (repl   (repl-substring-list-repl string replace-list pos)))
	(repl-substring string target repl pos))
      string))

(define (string-replace string target repl)
  (let loop ((str string) (pos 0))
    (if (>= pos (string-length str))
	str
	(loop (repl-substring str target repl pos) 
	      (if (repl-substring? str target pos)
		  (+ (string-length repl) pos)
		  (+ 1 pos))))))

(define (string-replace-list string replace-list)
  (let loop ((str string) (pos 0))
    (if (>= pos (string-length str))
	str
	(loop (repl-substring-list str replace-list pos) 
	      (if (repl-substring-list? str replace-list pos)
		  (+ (string-length 
		      (repl-substring-list-repl str replace-list pos)) 
		     pos)
		  (+ 1 pos))))))

;; ======================================================================

(define (ancestral-member nd gilist)
  (if (node-list-empty? nd)
      (empty-node-list)
      (if (member (gi nd) gilist)
	  nd
	  (ancestral-member (parent nd) gilist))))

;; ======================================================================

(define (node-list-filter-by-gi nodelist gilist)
  (let loop ((result (empty-node-list)) (nl nodelist))
    (if (node-list-empty? nl)
	result
	(if (member (gi (node-list-first nl)) gilist)
	    (loop (node-list result (node-list-first nl)) 
		  (node-list-rest nl))
	    (loop result (node-list-rest nl))))))

;; ======================================================================

(define (component-child-number inputnd)
  (let ((nd (ancestral-member inputnd component-element-list)))
    (let loop ((nl (select-elements (descendants nd) (gi inputnd)))
	       (num 1))
      (if (node-list-empty? nl)
	  0
	  (if (node-list=? (node-list-first nl) inputnd)
	      num
	      (if (string=? (gi (node-list-first nl)) (gi inputnd))
		  (loop (node-list-rest nl) (+ num 1))
		  (loop (node-list-rest nl) num)))))))

;; ======================================================================

;; Returns #t if the current-node is the beginning of a book (the first
;; division or component of the book).  (Since the current-node could be
;; something inside, like a TITLE, we look for the parent)
;;
(define (book-start?)
  (let ((book (ancestor "BOOK"))
	(nd   (ancestral-member 
	       (current-node) 
	       (append component-element-list division-element-list))))
    (let loop ((ch (children book)))
      (if (node-list-empty? ch)
	  #f
	  (if (member (gi (node-list-first ch)) 
		      (append component-element-list division-element-list))
	      (node-list=? (node-list-first ch) nd)
	      (loop (node-list-rest ch)))))))