path: root/support/utils.scm

;;; utils.scm -- utility functions
;;;
;;; author :  Sandra Loosemore
;;; date   :  18 Nov 1991
;;;
;;; This file contains miscellaneous functions that are generally useful.
;;; If you find some missing feature from the base language, this is
;;; a good place to put it.  Common Lisp-style sequence functions are 
;;; an example of the sort of thing found here.


;;;=====================================================================
;;; Sequence functions
;;;=====================================================================

(define (vector-replace to-vec from-vec to start end)
  (declare (type fixnum to start end)
	   (type vector to-vec from-vec))
  (if (and (eq? to-vec from-vec)
	   (> to start))
      ;; Right shift in place
      (do ((from  (1- end) (1- from))
	   (to    (1- (+ to (- end start)))))
	  ((< from start) to-vec)
	  (declare (type fixnum from to))
	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
	  (decf to))
      ;; Normal case, left-to-right
      (do ((from  start (1+ from)))
	  ((= from end) to-vec)
	  (declare (type fixnum from))
	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
	  (incf to))))

(define (string-replace to-vec from-vec to start end)
  (declare (type fixnum to start end)
	   (type string to-vec from-vec))
  (if (and (eq? to-vec from-vec)
	   (> to start))
      ;; Right shift in place
      (do ((from  (1- end) (1- from))
	   (to    (1- (+ to (- end start)))))
	  ((< from start) to-vec)
	  (declare (type fixnum from to))
	  (setf (string-ref to-vec to) (string-ref from-vec from))
	  (decf to))
      ;; Normal case, left-to-right
      (do ((from  start (1+ from)))
	  ((= from end) to-vec)
	  (declare (type fixnum from))
	  (setf (string-ref to-vec to) (string-ref from-vec from))
	  (incf to))))

(define (string-fill string c start end)
  (declare (type fixnum start end)
	   (type string string)
	   (type char c))
  (do ((i start (1+ i)))
      ((= i end) string)
      (declare (type fixnum i))
      (setf (string-ref string i) c)))

(define (string-position c string start end)
  (declare (type fixnum start end)
	   (type string string)
	   (type char c))
  (cond ((= start end) '#f)
	((char=? (string-ref string start) c) start)
	(else
	 (string-position c string (1+ start) end))))

(define (string-position-not-from-end c string start end)
  (declare (type fixnum start end)
	   (type string string)
	   (type char c))
  (cond ((= start end) '#f)
	((not (char=? (string-ref string (setf end (1- end))) c))
	 end)
	(else
	 (string-position-not-from-end c string start end))))

(define (string-nreverse string start end)
  (declare (type fixnum start end)
	   (type string string))
  (do ((i start (1+ i))
       (j (1- end) (1- j)))
      ((not (< i j)) string)
      (declare (type fixnum i j))
    (let ((c (string-ref string i)))
      (setf (string-ref string i) (string-ref string j))
      (setf (string-ref string j) c))))


(define (string-starts? s1 s2)  ; true is s1 begins s2
  (and (>= (string-length s2) (string-length s1))
       (string=? s1 (substring s2 0 (string-length s1)))))


;;;=====================================================================
;;; Table utilities
;;;=====================================================================


(define (table->list table)
  (let ((l '()))
       (table-for-each
	(lambda (key val) (push (cons key val) l)) table)
       l))

(define (list->table l)
  (let ((table (make-table)))
     (dolist (p l)
	(setf (table-entry table (car p)) (cdr p)))
     table))



;;;=====================================================================
;;; Tuple utilities
;;;=====================================================================

;;; For future compatibility with a typed language, define 2 tuples with
;;; a few functions:  (maybe add 3 tuples someday!)

(define-integrable (tuple x y)
  (cons x y))

(define-integrable (tuple-2-1 x) (car x))  ; Flic-like notation
(define-integrable (tuple-2-2 x) (cdr x))

(define (map-tuple-2-1 f l)
  (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l))

(define (map-tuple-2-2 f l)
  (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l))


;;;=====================================================================
;;; List utilities
;;;=====================================================================

;;; This does an assq using the second half of the tuple as the key.

(define (rassq x l)
  (if (null? l)
      '#f
      (if (eq? x (tuple-2-2 (car l)))
	  (car l)
	  (rassq x (cdr l)))))

;;; This is an assoc with an explicit test

(define (assoc/test test-fn x l)
  (if (null? l)
      '#f
      (if (funcall test-fn x (tuple-2-1 (car l)))
	  (car l)
	  (assoc/test test-fn x (cdr l)))))




;;; Stupid position function works only on lists, uses eqv?

(define (position item list)
  (position-aux item list 0))

(define (position-aux item list index)
  (declare (type fixnum index))
  (cond ((null? list)
	 '#f)
	((eqv? item (car list))
	 index)
	(else
	 (position-aux item (cdr list) (1+ index)))
	))


;;; Destructive delete-if function

(define (list-delete-if f l)
  (list-delete-if-aux f l l '#f))

(define (list-delete-if-aux f head next last)
  (cond ((null? next)
	 ;; No more elements.
	 head)
	((not (funcall f (car next)))
	 ;; Leave this element and do the next.
	 (list-delete-if-aux f head (cdr next) next))
	(last
	 ;; Delete element from middle of list.
	 (setf (cdr last) (cdr next))
	 (list-delete-if-aux f head (cdr next) last))
	(else
	 ;; Delete element from head of list.
	 (list-delete-if-aux f (cdr next) (cdr next) last))))


;;; Same as the haskell function

(define (concat lists)
  (if (null? lists)
      '()
      (append (car lists) (concat (cdr lists)))))


;;; This is a quick & dirty list sort function.

(define (sort-list l compare-fn)
  (if (or (null? l) (null? (cdr l)))
      l
      (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn))))

(define (insert-sorted compare-fn e l)
  (if (null? l)
      (list e)
      (if (funcall compare-fn e (car l))
	  (cons e l)
	  (cons (car l) (insert-sorted compare-fn e (cdr l))))))

(define (find-duplicates l)
  (cond ((null? l)
	 '())
	((memq (car l) (cdr l))
	 (cons (car l)
	       (find-duplicates (cdr l))))
	(else (find-duplicates (cdr l)))))

;;;  A simple & slow topsort routine.
;;;  Input:  A list of lists.  Each list is a object consed onto the
;;;          list of objects it preceeds.
;;;  Output: Two values: SORTED / CYCLIC & a list of either sorted objects
;;;                      or a set of components containing the cycle.

(define (topsort l)
  (let ((changed? '#t)
	(sorted '())
	(next '()))
    (do () ((not changed?) 
	    (if (null? next)
		(values 'sorted (nreverse sorted))
		(values 'cyclic (map (function car) next))))
      (setf changed? '#f)
      (setf next '())
      (dolist (x l)
        (cond ((topsort-aux (cdr x) sorted)
	       (push (car x) sorted)
	       (setf changed? '#t))
	      (else
	       (push x next))))
      (setf l next))))


;;; Returns true if x doesn't contain any elements that aren't in sorted.
;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons
;;; and doesn't traverse the whole list in the failure case.

(define (topsort-aux x sorted)
  (cond ((null? x)
	 '#t)
	((memq (car x) sorted)
	 (topsort-aux (cdr x) sorted))
	(else
	 '#f)))

(define (set-intersection s1 s2)
  (if (null? s1)
      '()
      (let ((rest (set-intersection (cdr s1) s2)))
	(if (memq (car s1) s2)
	    (cons (car s1) rest)
	    rest))))

;;; remove s2 elements from s1

(define (set-difference s1 s2)
  (if (null? s1)
      '()
      (let ((rest (set-difference (cdr s1) s2)))
	(if (memq (car s1) s2)
	    rest
	    (cons (car s1) rest)))))


(define (set-union s1 s2)
  (if (null? s2)
      s1
      (if (memq (car s2) s1)
	  (set-union s1 (cdr s2))
	  (cons (car s2) (set-union s1 (cdr s2))))))


;;; Destructive list splitter

(define (split-list list n)
  (declare (type fixnum n))
  (let ((tail1  (list-tail list (1- n))))
    (if (null? tail1)
	(values list '())
	(let ((tail2  (cdr tail1)))
	  (setf (cdr tail1) '())
	  (values list tail2)))))


;;; Some string utils

(define (mem-string s l)
  (and (not (null? l)) (or (string=? s (car l))
			   (mem-string s (cdr l)))))

(define (ass-string k l)
  (cond ((null? l)
	 '#f)
	((string=? k (caar l))
	 (car l))
	(else
	 (ass-string k (cdr l)))))


;;;=====================================================================
;;; Syntax extensions
;;;=====================================================================

;;; The mlet macro combines let* and multiple-value-bind into a single
;;; syntax.

(define-syntax (mlet binders . body)
  (mlet-body binders body))

(define (mlet-body binders body)
  (if (null? binders)
      `(begin ,@body)
      (let* ((b (car binders))
	     (var (car b))
	     (init (cadr b))
	     (inner-body (mlet-body (cdr binders) body)))
	(if (pair? var)
	    (multiple-value-bind (new-vars ignore-decl)
				 (remove-underlines var)
	       `(multiple-value-bind ,new-vars
				     ,init ,@ignore-decl ,inner-body))
	    `(let ((,var ,init)) ,inner-body)))))

(define (remove-underlines vars)
  (if (null? vars)
      (values '() '())
      (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars))
	(if (not (eq? (car vars) '_))
	    (values (cons (car vars) rest) ignore-decl)
	    (let ((var (gensym)))
	      (values (cons var rest)
		      `((declare (ignore ,var)) ,@ignore-decl)))))))




;;;=====================================================================
;;; Other utilities
;;;=====================================================================

(define (add-extension name ext)
  (assemble-filename (filename-place name) (filename-name name) ext))

(define (time-execution thunk)
  (let* ((start-time (get-run-time))
	 (res (funcall thunk))
	 (end-time (get-run-time)))
    (values res (- end-time start-time))))

(define (pprint-flatten code . maybe-port)
  (pprint-flatten-aux
    code
    (if (null? maybe-port) (current-output-port) (car maybe-port))))

(define (pprint-flatten-aux code port)
  (if (and (pair? code)
	   (eq? (car code) 'begin))
      (dolist (c (cdr code))
	(pprint-flatten-aux c port))
      (pprint*-aux code port)))

(define (print-flatten code port)
  (if (and (pair? code)
	   (eq? (car code) 'begin))
      (dolist (c (cdr code))
	(print-flatten c port))
      (begin
	(internal-write code port)
	(internal-newline port))))


;;; Like pprint, but print newline after instead of before.

(define (pprint* object . maybe-port)
  (pprint*-aux
    object
    (if (null? maybe-port) (current-output-port) (car maybe-port))))

(define (pprint*-aux object port)
  (dynamic-let ((*print-pretty*  '#t))
    (prin1 object port))
  (terpri port))

;;; This reads stuff from a string.  (Better error checks needed!)

(define (read-lisp-object str)
  (call-with-input-string str (lambda (port) (read port))))