From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 support/utils.scm | 408 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 408 insertions(+)
 create mode 100644 support/utils.scm

(limited to 'support/utils.scm')

diff --git a/support/utils.scm b/support/utils.scm
new file mode 100644
index 0000000..ab93f6b
--- /dev/null
+++ b/support/utils.scm
@@ -0,0 +1,408 @@
+;;; 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))))
-- 
cgit v1.2.3