;; Enumerated and finite types facility

;; Copyright (c) 2006 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; <dvanhorn@cs.brandeis.edu>

;; This is an implementation of the finite-types structure from Scheme 48.

(module finite-types mzscheme
  (provide define-enumerated-type define-finite-type)
  (require (lib "9.ss" "srfi")
           (lib "60.ss" "srfi"))
  
  (define-syntax define-enumerated-type
    (syntax-rules ()
      ((define-enumerated-type dispatcher type
         predicate instance-vector name-accessor index-accessor 
         (instance-name ...))
       (define-finite-type dispatcher type ()
         predicate instance-vector name-accessor index-accessor
         ((instance-name) ...)))))
  
  (define-syntax define-finite-type
    (syntax-rules ()
      ((define-finite-type dispatcher type field-tags
         predicate instance-vector name-accessor index-accessor
         field-clauses ... instances)
       (gen-names 
        (dispatcher type field-tags
                    predicate instance-vector name-accessor index-accessor
                    field-clauses ...)
        instances))))

  (define-syntax gen-names
    (syntax-rules ()
      ((gen-names proto instances)
       (gen-names proto instances () ()))
      ;; Generate fresh names for instances (reverses order).
      ((gen-names proto ((instance-name . fvs) . more) named n)
       (gen-names proto more 
                  ((%instance-name (+ . n) instance-name . fvs) . named) 
                  (1 . n)))
      ;; Done naming, now re-reverse the instance clauses.
      ((gen-names proto () named n) 
       (gen-names proto () named))
      ((gen-names proto ordered-instances (instance . more))
       (gen-names proto (instance . ordered-instances) more))
      ;; Done re-reversing.
      ((gen-names proto ordered-instances ())
       (define-finite-type* proto ordered-instances))))
      
  (define-syntax define-finite-type*
    (syntax-rules ()
      ((define-finite-type* 
         (dispatcher type
                     (field-tag-1 ...)
                     predicate instance-vector name-accessor index-accessor
                     (field-tag-2 accessor . ?modifier)
                     ...)
         ((%instance-name instance-id instance-name field-value ...) ...))
       (begin
         (define-record-type type (make-instance index field-tag-1 ...) 
           predicate 
           (index index)
           (field-tag-2 accessor . ?modifier) ...)
         (define %instance-name (make-instance instance-id field-value ...)) 
         ...
         (define-syntax dispatcher
           (syntax-rules (instance-name ...)
             ((dispatcher instance-name) %instance-name) ...))
         (define instance-vector (vector (dispatcher instance-name) ...))
         (define name-accessor 
           (let ((name-vector (apply vector '(instance-name ...))))
             (lambda (instance)
               (vector-ref name-vector (index instance)))))
         (define index-accessor index)))))

  ) ; end of finite-types module