
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : base.scm
;; DESCRIPTION : frequently used TeXmacs-independent Scheme subroutines
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
;;
;; This software falls under the GNU general public license and comes WITHOUT
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
;; If you don't have this file, write to the Free Software Foundation, Inc.,
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (display-list l)
  (if (not (null? l))
      (begin
	(display (car l))
	(display-list (cdr l)))))

(define display*
  (lambda l (display-list l)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execution
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (carr l) (car (reverse l)))
(define (crdrr l) (reverse (cdr (reverse l))))
(define (crdrdr l) (reverse (cdr (reverse (cdr l)))))

(define cons*
  (lambda l
    (let ((r (reverse l)))
      (append (reverse (cdr r)) (car r)))))

(define (map-unary r l)
  (if (null? l) l
      (cons (r (car l)) (map-unary r (cdr l)))))

(define (exec-unary r l)
  (if (not (null? l))
      (begin
	(r (car l))
	(exec-unary r (cdr l)))))

(define (in? x l)
  (cond ((null? l) #f)
	((equal? (car l) x) #t)
	(else (in? x (cdr l)))))

(define (list-starts? l what)
  (cond ((null? what) #t)
	((null? l) #f)
	(else (and (equal? (car l) (car what))
		   (list-starts? (cdr l) (cdr what))))))

(define (sublist l i j)
  (if (> i 0)
      (if (null? l) l (sublist (cdr l) (- i 1) (- j 1)))
      (if (> j 0)
	  (if (null? l) l (cons (car l) (sublist (cdr l) 0 (- j 1))))
	  '())))

(define (list-replace l what by)
  (cond ((null? l) l)
	((list-starts? l what)
	 (let ((tail (sublist l (length what) (length l))))
	   (append by (list-replace tail what by))))
	(else (cons (car l) (list-replace (cdr l) what by)))))

(define (split l pred)
  (if (null? l) (list l l)
      (if (pred (car l))
	  (list '() l)
	  (let ((p (split (cdr l) pred)))
	    (list (cons (car l) (car p)) (cadr p))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (char->string c) (list->string (list c)))

(define (string-ends? s what)
  (let ((n (string-length s))
	(k (string-length what)))
    (and (>= n k) (equal? (substring s (- n k) n) what))))

(define (string-replace s what by)
  (list->string
   (list-replace
    (string->list s)
    (string->list what)
    (string->list by))))

(define (force-string s)
  (if (string? s) s ""))

(define func?
  (lambda l
    (let ((n (length l)))
      (cond ((= n 2)
	     (let ((x (car l)) (f (cadr l)))
	       (and (list? x) (not (null? x)) (equal? (car x) f))))
	    ((= n 3)
	     (let ((x (car l)) (f (cadr l)) (nn (caddr l)))
	       (and (list? x) (not (null? x))
		    (equal? (car x) f) (= (length x) (+ nn 1)))))
	    (else #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dictionaries and sets
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (fill-dictionary-entry d key im)
  (if (not (null? key))
      (begin
	(hash-set! d (car key) im)
	(fill-dictionary-entry d (cdr key) im))))

(define (fill-dictionary d l)
  (if (not (null? l))
      (begin
	(let* ((r (reverse (car l))))
	  (fill-dictionary-entry d (cdr r) (car r)))
	(fill-dictionary d (cdr l)))))

(define (fill-set d l)
  (if (not (null? l))
      (begin
	(hash-set! d (car l) #t)
	(fill-set d (cdr l)))))
