;; Michael Orlov, orlovm@cs.bgu.ac.il
;; Last updated: June 6, 2000

;; Support:
;; type:    petite,chez,scm,mit-scheme,scheme48,mzscheme,drscheme,stk,snow
;; records:   x     x    x                         x        x      x   x

;; Determining the interpreter
(define scheme-implementation
  (cond
   ((inexact? (/ 1 2))
    (if (symbol? ':key)
        'scm
        (if (symbol-bound? 'tk-command?)
            'stk 'snow)))
   ((not '()) 'mit-scheme)
   ((symbol? (interaction-environment))
    (if (eq? (current-eval) interpret)
        'petite 'chez))
   ((procedure? (delay 1)) 'scheme48)
   (else
    (with-handlers
     ((exn:fail:contract:variable?
       (lambda (exn) 'mzscheme)))
      rgb? 'drscheme))))

;; Eval for scheme48
(if (eq? scheme-implementation 'scheme48)
    (eval
     '(define eval
        (let ((eval eval))
          (lambda (expr . env)
            (if (null? env)
                (eval expr (interaction-environment))
                (apply eval expr env)))))
     (interaction-environment)))

;; Values and Syntax support
(eval
 (let ((one- (string->symbol "1-")))
   `(begin
      ,@(case scheme-implementation
          ((petite chez)
           '((if (not (top-level-bound? 'scheme-init-level))
                 (eval
                  '(define format
                     (let ((format format))
                       (lambda (port . args)
                         (cond
                          ((eq? #t port) (apply printf args))
                          ((eq? #f port) (apply format args))
                          ((output-port? port)
                           (display (apply format args) port))
                          (else (apply format port args))))))))
             (define scheme-init-level 1)))
          ((scm)
           `((verbose 1)
             (require 'values)
             (require 'macro)
             ;; (require 'syntactic-closures)
             (require 'fluid-let)
             (require 'syntax-case)
             (require 'eval)
             (require 'common-list-functions)
             (require 'record)
             (require 'struct)
             (require 'pretty-print)
             (require 'format)
             (require 'trace)
             (require 'random)
             (define add1 1+)
             (define sub1 ,one-)
             (define printf
               (lambda args
                 (apply format #t args)))
             (if (eq? error slib:error)
                 (define error
                   (let ((error error))
                     (lambda (name . form)
                       (error
                        (string-append
                         (symbol->string name)
                         " -- " (apply format form) "."))))))
             (define call/cc call-with-current-continuation)
             (defmacro let-syntax args
               (macro:expand `(let-syntax ,@args)))
             (defmacro letrec-syntax args
               (macro:expand `(letrec-syntax ,@args)))
             (define expand macro:expand)))
          ((mzscheme drscheme)
           `((require (lib "trace.ss"))
             (require (lib "pretty.ss"))
             (require (lib "defmacro.ss"))
             (define 1+ add1)
             (define ,one- sub1)))
          ((stk snow)
           `((define add1 1+)
             (define sub1 ,one-)
             (require "Tk-classes")
             (if (not (closure? format))
                 (define format
                   (let ((format format))
                     (lambda (form . args)
                       (if (string? form)
                           (apply format #f form args)
                           (apply format form args))))))
             (define printf
               (lambda args
                 (apply format #t args)))
             (if (not (closure? error))
                 (define error
                   (let ((error error))
                     (lambda (name form . args)
                       (apply error
                              (string-append
                               (symbol->string name) " -- " form ".")
                              args)))))))
          ((scheme48)
           '((define add1 (lambda (n) (+ n 1)))
             (define sub1 (lambda (n) (- n 1)))
             (define 1+ add1)
             (define ,one- sub1)))
          (else '(#t))))))

(define unspecified-value (if #f #f))

;; List Abstractions
(define filter
  (lambda (pred? seq)
    (fold-right
     (lambda (first rest)
       (if (pred? first)
           `(,first ,@rest)
           rest))
     '() seq)))

(define flatmap
  (lambda (proc . seqs)
    (fold-left append '()
               (apply map proc seqs))))

(define fold-left
  (lambda (op init seq)
    (if (null? seq)
        init
        (fold-left op (op init (car seq))
                   (cdr seq)))))

(define fold-right
  (lambda (op init seq)
    (if (null? seq)
        init
        (op (car seq)
            (fold-right op init (cdr seq))))))

(define mapand
  (lambda (pred? seq)
    (cond ((null? seq) #t)
          ((pred? (car seq))
           (mapand pred? (cdr seq)))
          (else #f))))

(define iota
  (letrec
      ((iota-up
        (lambda (low high inc)
          (if (> low high) '()
              `(,low ,@(iota-up (+ low inc) high inc)))))
       (iota-dn
        (lambda (low high inc)
          (if (< low high) '()
              `(,low ,@(iota-dn (+ low inc) high inc))))))
    (lambda (low . high+inc)
      (cond
       ((null? high+inc)
        (iota-up 0 low 1))
       ((null? (cdr high+inc))
        (iota-up low (car high+inc) 1))
       ((positive? (cadr high+inc))
        (apply iota-up low high+inc))
       ((negative? (cadr high+inc))
        (apply iota-dn low high+inc))
       (else
        (let ((inf-low `(,low)))
          (set-cdr! inf-low inf-low)
          inf-low))))))
            
;; CPS List Abstractions
(define map$
  (lambda (proc$ seq succ fail)
    (if (null? seq)
        (succ '())
        (proc$ (car seq)
               (lambda (res1)
                 (map$ proc$ (cdr seq)
                       (lambda (res2)
                         (succ `(,res1 ,@res2)))
                       fail))
               fail))))

(define flatmap$
  (lambda (proc$ seq succ fail)
    (if (null? seq)
        (succ '())
        (proc$ (car seq)
               (lambda (res1)
                 (flatmap$ proc$ (cdr seq)
                           (lambda (res2)
                             (succ `(,@res1 ,@res2)))
                           fail))
               fail))))

(define part/pred$
  (lambda (pred?)
    (letrec
        ((part$
          (lambda (s ret-yes-no)
            (if (null? s)
                (ret-yes-no '() '())
                (part$
                 (cdr s)
                 (lambda (yes no)
                   (if (pred? (car s))
                       (ret-yes-no `(,(car s) ,@yes) no)
                       (ret-yes-no yes `(,(car s) ,@no)))))))))
      part$)))

;; Operations on Lists
(define list-single?
  (lambda (s)
    (and (pair? s)
         (null? (cdr s)))))
(define list-double?
  (lambda (s)
    (and (pair? s)
         (list-single? (cdr s)))))

(define uniqify
  (letrec
      ((uniqify
        (lambda (exps done)
          (if (null? exps)
              done
              (uniqify
               (cdr exps)
               (if (memq (car exps) (cdr exps))
                   done
                   `(,(car exps) ,@done)))))))
    (lambda (s)
      (uniqify s '()))))
(define adjoin
  (lambda (e l)
    (if (memv e l) l (cons e l))))
(define union
  (lambda (l1 l2)
    (cond ((null? l1) l2)
          ((null? l2) l1)
          (else (union (cdr l1) (adjoin (car l1) l2))))))
(define intersection
  (lambda (l1 l2)
    (cond ((null? l1) l1)
          ((null? l2) l2)
          ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
          (else (intersection (cdr l1) l2)))))
(define set-difference
  (lambda (l1 l2)
    (cond ((null? l1) l1)
          ((memv (car l1) l2) (set-difference (cdr l1) l2))
          (else (cons (car l1) (set-difference (cdr l1) l2))))))
(define position
  (lambda (obj lst)
    (letrec ((pos (lambda (n lst)
                    (cond ((null? lst) #f)
                          ((eqv? obj (car lst)) n)
                          (else (pos (+ 1 n) (cdr lst)))))))
      (pos 0 lst))))
(define substitute
  (lambda (s alist)
    (cond ((assv s alist) => cadr)
          ((pair? s)
           (cons (substitute (car s) alist)
                 (substitute (cdr s) alist)))
          (else s))))

;; Function Abstractions
(define id values)

(define compose
  (lambda funcs
    (cond
     ((null? funcs)
      id)
     ((null? (cdr funcs))
      (car funcs))
     (else
      (let ((first (car funcs))
            (rest (apply compose (cdr funcs))))
        (lambda args
          (call-with-values
              (lambda ()
                (apply rest args))
            first)))))))

(define with
  (lambda (s f)
    (apply f s)))

;; Symbol Generation
(define integer->symbol
  (let ((reserved-words
         '(if lambda)))
    (lambda (i)
      (let* ((str (integer->string i))
             (sym (string->symbol str)))
        (if (memq sym reserved-words)
            (string->symbol
             (string-append str "*"))
            sym)))))

(define integer->string
  (let ((priorities
         '#(#\x #\y #\z #\w #\p #\q #\s #\t #\r #\m #\n #\k #\i
            #\j #\a #\b #\c #\d #\e #\f #\g #\v #\u #\h #\l #\o)))
    (letrec ((integer->chars
              (lambda (i)
                (if (< i 26)
                    `(,(vector-ref priorities i))
                    `(,@(integer->chars (sub1 (quotient i 26)))
                      ,@(integer->chars (modulo i 26)))))))
      (lambda (i)
        (list->string (integer->chars i))))))

(define new-variable
  (lambda (veto)
    (letrec
        ((new-variable
          (lambda (base)
            (let ((var (integer->symbol base)))
              (if (memq var veto)
                  (new-variable (1+ base))
                  var)))))
      (new-variable 0))))

;; Math
(define (square x) (* x x))
(define (cube x) (* x x x))
(define (divides? a b) (or (zero? b) (zero? (modulo b a))))
(define (double x) (* x 2))
(define (halve x) (/ x 2))
(define (average . values)
  (/ (apply + values) (length values)))

(define (make-matrix m n . fill)
  (if (and (pair? fill) (not (null? (cdr fill))))
      (error 'make-matrix "wrong number of arguments")
      (let ((fill (if (null? fill) 0 (car fill))))
        (do ((m-array (make-vector m))
             (i 0 (1+ i)))
            ((= i m) m-array)
          (vector-set! m-array i
                       (make-vector n fill))))))
(define (matrix-set! matrix i j value)
  (vector-set! (vector-ref matrix i) j value))
(define (matrix-ref matrix i j)
  (vector-ref (vector-ref matrix i) j))
(define (matrix-rows matrix)
  (vector-length matrix))
(define (matrix-columns matrix)
  (vector-length (vector-ref matrix 0)))

(define pi (acos -1))
(define e (exp 1))

(define qceiling
  (lambda (a b)
    (quotient (+ a b -1) b)))

(define positive-infinity (/ 1 0.0))
(define negative-infinity (/ -1 0.0))

(define-syntax swap!
  (syntax-rules ()
    ((swap x y)
     (let ((z x))
       (set! x y)
       (set! y z)))))

;; Records
(case scheme-implementation
  ((petite chez)
   (eval
    ;; Adopting variant-case from EOPL
    '(extend-syntax (variant-case else)
       ((variant-case var)
        (void))
       ((variant-case var (else exp1 exp2 ...))
        (begin exp1 exp2 ...))
       ((variant-case exp clause ...)
        (not (symbol? 'exp))
        (with ((var (gensym)))
              (let ((var exp))
                (variant-case var clause ...))))
       ((variant-case var (name (field ...) exp1 exp2 ...) clause ...)
        (with (((make-name name? name->field ...)
                ((lambda (name fields)
                   (let ((name-str (symbol->string name)))
                     `(,(string->symbol (string-append "make-" name-str))
                       ,(string->symbol (string-append name-str "?"))
                       ,@(map (lambda (field)
                                (string->symbol
                                 (string-append name-str "-"
                                                (symbol->string field))))
                              fields))))
                 'name '(field ...))))
              (if (name? var)
                  (let ((field (name->field var)) ...)
                    exp1 exp2 ...)
                  (variant-case var clause ...)))))))
  ((scm)
   (eval
    '(begin
       ;; Adding name-field (instead of name->field)
       (defmacro define-record args
         (if (not (and (pair? args)
                       (symbol? (car args))
                       (pair? (cdr args))
                       (list? (cadr args))
                       (comlist:every symbol? (cadr args))
                       (not (struct:duplicate-fields? (cadr args)))
                       (null? (cddr args))))
             (error 'define-record "invalid parameters syntax ~s" args)
             (let ((tag (car args))
                   (name (symbol->string (car args)))
                   (fields (map symbol->string (cadr args))))
               (let ((make-name (string->symbol
                                 (string-append "make-" name)))
                     (name? (string->symbol (string-append name "?")))
                     (name->field
                      (map (lambda (field)
                             (string->symbol
                              (string-append name "->" field)))
                           fields))
                     (name-field
                      (map (lambda (field)
                             (string->symbol
                              (string-append name "-" field)))
                           fields))
                     (set-name-field!
                      (map (lambda (field)
                             (string->symbol
                              (string-append "set-" name "-" field "!")))
                           fields)))
                 (letrec
                     ((make-fields
                       (lambda (field-accessors i)
                         (if (null? field-accessors) '()
                             `((define ,(car field-accessors)
                                 (lambda (obj)
                                   (if (,name? obj)
                                       (vector-ref obj ,i)
                                       (error ',(car field-accessors)
                                              "invalid record ~s" obj))))
                               ,@(make-fields (cdr field-accessors)
                                              (1+ i))))))
                      (make-setters
                       (lambda (field-setters i)
                         (if (null? field-setters) '()
                             `((define ,(car field-setters)
                                 (lambda (obj val)
                                   (if (,name? obj)
                                       (vector-set! obj ,i val)
                                       (error ',(car field-setters)
                                              "invalid record ~s" obj))))
                               ,@(make-setters (cdr field-setters)
                                               (1+ i)))))))
                   `(begin
                      (define ,make-name
                        (lambda ,name-field
                          (vector ',tag ,@name-field)))
                      (define ,name?
                        (lambda (obj)
                          (and (vector? obj)
                               (= (vector-length obj)
                                  ,(1+ (length fields)))
                               (eq? ',tag (vector-ref obj 0)))))
                      ,@(make-fields name-field 1)
                      ,@(map (lambda (n->f n-f)
                               `(define ,n->f ,n-f))
                             name->field name-field)
                      ,@(make-setters set-name-field! 1))))))))))
  ((mzscheme drscheme)
   (eval
    '(begin
       ;; Records
       (define-syntax define-record
         (syntax-rules ()
           ((define-record record fields)
            (define-struct record fields))))
       (define record? struct?)
       ;; Variant-Case
       (define-macro variant-case
         (letrec
             ((expand-variant-case
               (lambda (var clauses)
                 (cond
                  ((null? clauses)
                   (void))
                  ((and (pair? clauses)
                        (null? (cdr clauses))
                        (list? (car clauses))
                        (pair? (car clauses))
                        (pair? (cdar clauses))
                        (eq? 'else (caar clauses)))
                   `(begin ,@(cdar clauses)))
                  ((and (list? (car clauses))
                        (pair? (car clauses))
                        (pair? (cdar clauses))
                        (pair? (cddar clauses))
                        (list? (cadar clauses)))
                   (let ((name (caar clauses))
                         (fields (cadar clauses))
                         (body (cddar clauses)))
                     (apply (lambda (make-name name? . name-fields)
                              `(if (,name? ,var)
                                   (let ,(map (lambda (name name-field)
                                                `(,name (,name-field ,var)))
                                              fields name-fields)
                                     ,@body)
                                   ,(expand-variant-case var (cdr clauses))))
                            (record-proc-names name fields))))
                  (else (error 'expand-variant-case
                               "unrecognized syntax ~s" (car clauses))))))
              (record-proc-names
               (lambda (name fields)
                 (let ((name-str (symbol->string name)))
                   `(,(string->symbol (string-append "make-" name-str))
                     ,(string->symbol (string-append name-str "?"))
                     ,@(map (lambda (field)
                              (string->symbol
                               (string-append name-str "-"
                                              (symbol->string field))))
                            fields))))))
           (lambda (var . clauses)
             (if (symbol? var)
                 (expand-variant-case var clauses)
                 (let ((new-var (gensym)))
                   `(let ((,new-var ,var))
                      ,(expand-variant-case new-var clauses)))))))
       )))
  ((snow stk)
   (eval
    '(begin
       (define record?
         (lambda (r)
           (and (vector? r)
                (positive? (vector-length r))
                (symbol? (vector-ref r 0))
                (let ((r? (string->symbol
                           (string-append
                            (symbol->string (vector-ref r 0)) "?"))))
                  (and (symbol-bound? r?)
                       ((eval r?) r))))))
       (define-macro (define-record tag sfields)
         (let ((name (symbol->string tag))
               (fields (map symbol->string sfields)))
           (let ((make-name (string->symbol
                             (string-append "make-" name)))
                 (name? (string->symbol (string-append name "?")))
                 (name->field
                  (map (lambda (field)
                         (string->symbol
                          (string-append name "->" field)))
                       fields))
                 (name-field
                  (map (lambda (field)
                         (string->symbol
                          (string-append name "-" field)))
                       fields))
                 (set-name-field!
                  (map (lambda (field)
                         (string->symbol
                          (string-append "set-" name "-" field "!")))
                       fields)))
             (letrec
                 ((make-fields
                   (lambda (field-accessors i)
                     (if (null? field-accessors) '()
                         `((define ,(car field-accessors)
                             (lambda (obj)
                               (if (,name? obj)
                                   (vector-ref obj ,i)
                                   (error ',(car field-accessors)
                                          "invalid record ~s" obj))))
                           ,@(make-fields (cdr field-accessors)
                                          (1+ i))))))
                  (make-setters
                   (lambda (field-setters i)
                     (if (null? field-setters) '()
                         `((define ,(car field-setters)
                             (lambda (obj val)
                               (if (,name? obj)
                                   (vector-set! obj ,i val)
                                   (error ',(car field-setters)
                                          "invalid record ~s" obj))))
                           ,@(make-setters (cdr field-setters)
                                           (1+ i)))))))
               `(begin
                  (define ,make-name
                    (lambda ,name-field
                      (vector ',tag ,@name-field)))
                  (define ,name?
                    (lambda (obj)
                      (and (vector? obj)
                           (= (vector-length obj)
                              ,(1+ (length fields)))
                           (eq? ',tag (vector-ref obj 0)))))
                  ,@(make-fields name-field 1)
                  ,@(map (lambda (n->f n-f)
                           `(define ,n->f ,n-f))
                         name->field name-field)
                  ,@(make-setters set-name-field! 1))))))
       (define-macro (variant-case var . clauses)
         (letrec
             ((expand-variant-case
               (lambda (var clauses)
                 (cond
                  ((null? clauses)
                   (if #f #f))
                  ((and (list-single? clauses)
                        (list? (car clauses))
                        (pair? (car clauses))
                        (pair? (cdar clauses))
                        (eq? 'else (caar clauses)))
                   `(begin ,@(cdar clauses)))
                  ((and (list? (car clauses))
                        (pair? (car clauses))
                        (pair? (cdar clauses))
                        (pair? (cddar clauses))
                        (list? (cadar clauses)))
                   (let ((name (caar clauses))
                         (fields (cadar clauses))
                         (body (cddar clauses)))
                     (with (record-proc-names name fields)
                       (lambda (make-name name? . name-fields)
                         `(if (,name? ,var)
                              (let ,(map (lambda (name name-field)
                                           `(,name (,name-field ,var)))
                                         fields name-fields)
                                ,@body)
                              ,(expand-variant-case var (cdr clauses)))))))
                  (else (error 'expand-variant-case
                               "unrecognized syntax ~s" (car clauses))))))
              (record-proc-names
               (lambda (name fields)
                 (let ((name-str (symbol->string name)))
                   `(,(string->symbol (string-append "make-" name-str))
                     ,(string->symbol (string-append name-str "?"))
                     ,@(map (lambda (field)
                              (string->symbol
                               (string-append name-str "-"
                                              (symbol->string field))))
                            fields))))))
           (if (symbol? var)
               (expand-variant-case var clauses)
               (let ((new-var (gensym)))
                 `(let ((,new-var ,var))
                    ,(expand-variant-case new-var clauses)))))))))
  (else (display "Warning: no EOPL records for implementation ")
        (display scheme-implementation)
        (display ".") (newline)))

;; Streams
(define ^empty-stream (lambda () '()))
(define stream-empty? null?)
(define-syntax ^stream
  (syntax-rules ()
    ((^stream head tail)
     `(,head . ,(delay tail)))))
(define stream-car car)
(define stream-cdr (lambda (s) (force (cdr s))))
(define-syntax ^stream-list
  (syntax-rules ()
    ((^stream-list)
     (^empty-stream))
    ((^stream-list head)
     (^stream head (^stream-list)))
    ((^stream-list head next ...)
     (^stream head (^stream-list next ...)))))

(define stream-ref
  (lambda (s n)
    (if (zero? n)
        (stream-car s)
        (stream-ref (stream-cdr s) (sub1 n)))))

(define stream-length
  (letrec
      ((stream-length
        (lambda (s n)
          (if (stream-empty? s) n
              (stream-length (stream-cdr s) (1+ n))))))
    (lambda (s)
      (stream-length s 0))))

(define stream-fold-left
  (lambda (op init stream)
    (if (stream-empty? stream) init
        (stream-fold-left op (op init (stream-car stream))
                          (stream-cdr stream)))))

(define stream-map
  (lambda (proc . streams)
    (if (stream-empty? (car streams))
        (^empty-stream)
        (^stream
         (apply proc (map stream-car streams))
         (apply stream-map
                proc (map stream-cdr streams))))))

(define stream-for-each
  (lambda (proc . streams)
    (apply stream-map
           (lambda items
             (apply proc items)
             items)
           streams)))

(define stream-filter
  (lambda (pred? stream)
    (if (stream-empty? stream)
        (^empty-stream)
        (let ((head (stream-car stream)))
          (if (pred? head)
              (^stream head
                       (stream-filter
                        pred? (stream-cdr stream)))
              (stream-filter pred? (stream-cdr stream)))))))

(define stream-consume
  (lambda (cont? stream)
    (if (and (not (stream-empty? stream))
             (cont? stream))
        (stream-consume cont? (stream-cdr stream)))))

(define stream-print
  (lambda (stream . num)
    (let ((printing-stream
           (stream-for-each (lambda (item)
                              (display item)
                              (newline))
                            stream)))
      (cond
       ((null? num)
        (stream-consume (lambda (x) #t) printing-stream))
       ((not (null? (cdr num)))
        (error 'stream-print "incorrect arguments"))
       (else
        (let ((count (car num)))
          (stream-consume
           (lambda (x)
             (set! count (sub1 count))
             (not (zero? count)))
           printing-stream)))))))

(define streams-merge
  (lambda (pred<=? s1 s2)
    (cond
     ((stream-empty? s2) s1)
     ((stream-empty? s1) s2)
     (else
      (let ((head1 (stream-car s1))
            (head2 (stream-car s2)))
        (if (pred<=? head1 head2)
            (^stream head1
                     (streams-merge pred<=? (stream-cdr s1) s2))
            (^stream head2
                     (streams-merge pred<=? s1 (stream-cdr s2)))))))))

(define streams-convolve
  (lambda (pred<=? combine s1 s2)
    (cond
     ((stream-empty? s2) s2)
     ((stream-empty? s1) s1)
     (else
      (let ((head1 (stream-car s1)))
        (^stream
         (combine head1 (stream-car s2))
         (streams-merge
          pred<=?
          (stream-map (lambda (item)
                        (combine head1 item))
                      (stream-cdr s2))
          (streams-convolve
           pred<=? combine
           (stream-cdr s1) s2))))))))

(define streams-interleave
  (lambda (s1 s2)
    (if (stream-empty? s1) s2
        (^stream
         (stream-car s1)
         (streams-interleave s2 (stream-cdr s1))))))

(define stream-uniques
  (letrec
      ((stream-uniques
        (lambda (s last)
          (if (stream-empty? s) s
              (let ((next (stream-car s)))
                (if (eqv? next last)
                    (stream-uniques (stream-cdr s) last)
                    (^stream next
                             (stream-uniques
                              (stream-cdr s) next))))))))
    (lambda (s)
      (stream-uniques s stream-uniques))))

;; Variable Dimension Tables
(define-record multi-table (vals subs))
(define-record multi-table-entry (key value))

(define ^empty-multi-table
  (lambda ()
    (make-multi-table '() '())))

(define multi-table-entry-lookup
  (lambda (entries key ret-entry ret-fail)
    (cond
     ((null? entries)
      (ret-fail))
     ((equal? key (multi-table-entry-key (car entries)))
      (ret-entry (car entries)))
     (else
      (multi-table-entry-lookup
       (cdr entries) key ret-entry ret-fail)))))

(define multi-table-lookup
  (lambda (table ret-value ret-fail key-1 . keys)
    (if (null? keys)
        (multi-table-entry-lookup
         (multi-table-vals table) key-1
         (lambda (entry)
           (ret-value (multi-table-entry-value entry)))
         ret-fail)
        (multi-table-entry-lookup
         (multi-table-subs table) key-1
         (lambda (entry)
           (apply multi-table-lookup
                  (multi-table-entry-value entry)
                  ret-value ret-fail
                  keys))
         ret-fail))))

(define multi-table-insert!
  (lambda (table value key-1 . keys)
    (if (null? keys)
        (multi-table-entry-lookup
         (multi-table-vals table) key-1
         (lambda (entry)
           (set-multi-table-entry-value! entry value))
         (lambda ()
           (set-multi-table-vals!
            table
            `(,(make-multi-table-entry key-1 value)
              ,@(multi-table-vals table)))))
        (multi-table-entry-lookup
         (multi-table-subs table) key-1
         (lambda (entry)
           (apply multi-table-insert!
                  (multi-table-entry-value entry)
                  value keys))
         (lambda ()
           (let ((new-table (make-multi-table '() '())))
             (set-multi-table-subs!
              table
              `(,(make-multi-table-entry key-1 new-table)
                ,@(multi-table-subs table)))
             (apply multi-table-insert!
                    new-table value keys)))))))

;; Put, Get (PPL)
(define *the-operation-and-type-table* (^empty-multi-table))
(define get
  (lambda (key-1 key-2)
    (multi-table-lookup *the-operation-and-type-table*
                        id (lambda () #f)
                        key-1 key-2)))
(define put
  (lambda (key-1 key-2 value)
    (multi-table-insert! *the-operation-and-type-table*
                         value key-1 key-2)))