Megatest

Artifact [fc9b32e569]
Login

Artifact fc9b32e569b8e86ba574919fc7677f2cd047281c:


;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;
(define (mutils:hierhash-ref hh . keys)
  (if (null? keys)
      #f
      (let loop ((ht   hh)
		 (key  (car keys))
		 (tail (cdr keys)))
	(if (null? tail)
	    (if (hash-table? ht)
		(hash-table-ref/default ht key #f)
		#f)
	    (if (hash-table? ht)
		(loop (hash-table-ref/default ht key #f)
		      (car tail)
		      (cdr tail))
		#f)))))

;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!!
;; val comes first!
;;
(define (mutils:hierhash-set! hh val . keys)
  (if (null? keys)
      #f
      (let loop ((ht    hh)
		 (key  (car keys))
		 (tail (cdr keys)))
	(if (null? tail) ;; last one!
	    (hash-table-set! ht key val)
	    (let ((nh (hash-table-ref/default ht key #f)))
	      (if (not nh)(set! nh (make-hash-table)))
	      (hash-table-set! ht key nh)
	      (loop nh
		    (car tail)
		    (cdr tail)))))))

;; nice little routine to add an item to a list in a hashtable 
;;
(define (mutils:hash-table-add-to-list htbl key item)
  (let ((l (hash-table-ref/default htbl key #f)))
    (if l
	(hash-table-set! htbl key (cons item l))
	(hash-table-set! htbl key (list item)))))

(define (mutils:hash-table-append-to-list htbl key lst)
  (let ((l (hash-table-ref/default htbl key #f)))
    (if l
	(hash-table-set! htbl key (append lst l))
        (hash-table-set! htbl key lst))))

;;======================================================================
;; Utils
;;======================================================================

(define (mutils:file->list fname)
  (let ((fh (open-input-file fname))
	(comment (regexp "^\\s*#"))
	(blank   (regexp "^\\s*$")))
    (let loop ((l   (read-line fh))
	       (res '()))
      (if (eof-object? l)
	  (reverse res)
	  (if (or (string-match comment l)
		  (string-match blank l))
	      (loop (read-line fh) res)
	      (loop (read-line fh) (cons l res)))))))

(use sparse-vectors)

;; this is a simple two dimensional sparse array

;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
  (let ((a (make-sparse-vector)))
    (sparse-vector-set! a 0 (make-sparse-vector))
    a))

(define (mutils:sparse-array? a)
  (and (sparse-vector? a)
       (sparse-vector? (sparse-vector-ref a 0))))

(define (mutils:sparse-array-ref a x y)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-ref row y)
	#f)))

(define (mutils:sparse-array-set! a x y val)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-set! row y val)
	(let ((new-row (make-sparse-vector)))
	  (sparse-vector-set! a x new-row)
	  (sparse-vector-set! new-row y val)))))

;; some routines for treating assoc lists a bit like hash tables

(define (mutils:assoc-get/default alist key default)
  (let ((res (assoc key alist)))
    (if (and res (list? res)(> (length res) 1))
	(cadr res)
	default)))

(define (mutils:assoc-get alist key)
  (cadr (assoc key alist)))

(define (mutils:hier-list? @hierlist)
  (and (list? @hierlist)
       (> (length @hierlist) 0)
       (list? (car @hierlist))
       (> (length (car @hierlist)) 1)))

(define (mutils:hier-list-get @hierlist . @path)
  (if (list? @hierlist)
      (let* (($path (car @path))
	     (@rempath (cdr @path))
	     (@match (assoc $path @hierlist)))
	(if @match
	    (if (or (not (list? @rempath))(null? @rempath))
		(cadr @match)
		(apply mutils:hier-list-get (cadr @match) @rempath))
	    #f))
      #f))

(define (mutils:hier-list-put! @hierlist . @path)
  (let* (($path (car @path))
	 (@rempath (cdr @path))
	 ($value   (cadr @path))
	 (@match (assoc $path @hierlist))
	 (@remhierlist (remove (lambda (a)
                                 (equal? a @match))
                               @hierlist))
         (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
	 (@new-pair (list $path (if (eq? (length @rempath) 1) 
				    (car @rempath)
				    (apply mutils:hier-list-put! @old-pair @rempath)))))
    (cons @new-pair @remhierlist)))

(define (mutils:hier-list-remove! @hierlist . @path)
  (let (($path (car @path)))
    (if (eq? (length @path) 1)
	(remove (lambda (a)
                  (equal? a (assoc $path @hierlist)))
                @hierlist)
	(let* ((@rempath (cdr @path))
	       (@match (assoc $path @hierlist))
	       (@remhierlist (remove (lambda (a) 
                                       (equal? @match a))
                                     @hierlist))
	       (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
	       (@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath))))
	  (cons @new-pair @remhierlist)))))

(define (mutils:keys @hierlist . @path)
  (map (lambda (@l)
	 (if (and (list? @l)(not (null? @l))) 
	     (car @l))) 
       (if (null? @path) @hierlist
	   (apply mutils:hier-list-get @hierlist @path))))