;;; Making SCM more MIT Scheme compatible...

(require 'hash-table)
(define (hash-table/get hashtab key default)
  (or ((hash-inquirer equal?) hashtab key) default))
(define hash-table/put! (hash-associator equal?))
(define hash-table/remove! (hash-remover equal?))
(define (make-equal-hash-table . size)
  (if (null? size) (make-hash-table 1009) (make-hash-table (car size))))
(define (make-eq-hash-table . size)
  (if (null? size) (make-hash-table 1009) (make-hash-table (car size))))

(require 'priority-queue)

;;; wt-tree supports lookup and delete operations 

(define (make-wt-tree-type fun)
  (lambda (x y) (not (fun (car x) (car y)))))

(define (make-wt-tree fun)		; SCM does max
  (make-heap fun))

(define (wt-tree/empty? wt)
  (= 0 (heap-length wt)))

(define (wt-tree/delete-min! wt)
  (heap-extract-max! wt))

(define (wt-tree/min-datum wt)
  (let ((max (heap-extract-max! wt)))
    (heap-insert! wt max)
    (cdr max)))

(define (wt-tree/add! wt key datum)
  (heap-insert! wt (cons key datum)))

(define (wt-tree/size wt) 
  (heap-length wt))

(define (load-option x) x)

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)

;;; Some compiler stuff
(defmacro (declare . x) '())
(defmacro (define-integrable . args) (cons 'define args))

(define (there-exists? x fn)
  (if (null? x) #f
      (if (fn (car x))
	  (car x)
	  (there-exists? (cdr x) fn))))

(define (for-all? x fn)
  (if (null? x) #t
      (if (fn (car x)) 
	  (for-all? (cdr x) fn)
	  #f)))

(define (symbol-append . l)
  (string->symbol (apply string-append (map symbol->string l))))

(define (i-list l i)		; list of ints starting with i
  (if (null? l) '()
      (cons i (i-list (cdr l) (+ i 1)))))

#|

;;; A vector based representation
(defmacro (define-structure name-info . components)
  (let ((name (if (pair? name-info) (first name-info) name-info)))
    (append
     `(begin
	(define (,(symbol-append 'make '- name) . vals) 
	  (let ((entry (make-vector ,(+ 1 (length components)))))
	    (vector-set! entry 0 ',name)
	    (for-each
	     (lambda (val i) (vector-set! entry i val))
	     vals
	     ',(i-list components 1))
	    entry))
	(define (,(symbol-append name '?) entry) 
	  (and (vector? entry) (eq? ',name (vector-ref entry 0))))
	)
     ;; Create each of the access and set functions
     (apply append
	    (map (lambda (c i)		; c if component name
		   (list
		    ;; Create name-<c>
		    `(define (,(symbol-append name '- c) entry) 
		       (vector-ref entry ,i))
		    ;; Create set-name-<c>!
		    `(define (,(symbol-append 'set '- name '- c '!) entry x) 
		       (vector-set! entry ,i x))))
		 components
		 (i-list components 1))))
    ))
|#

(require 'record)

(defmacro (define-structure name-info . components)
  (let* ((name (if (pair? name-info) (first name-info) name-info)))
    (append
     `(begin
	(define *rtd* (make-record-type ',name ',components))
	(define ,(symbol-append 'make '- name)
	  (record-constructor *rtd*))
	(define ,(symbol-append name '?)
	  (record-predicate *rtd*))
	)
     ;; Create each of the access and set functions
     (apply append
	    (map (lambda (c)		; c if component name
		   (list
		    ;; Create name-<c>
		    `(define ,(symbol-append name '- c)
		       (record-accessor *rtd* ',c))
		    ;; Create set-name-<c>!
		    `(define ,(symbol-append 'set '- name '- c '!)
		       (record-modifier *rtd* ',c))))
		 components)))
    ))