(module pool mzscheme

  (require "atom.ss"
           "timestamp.ss"
           "require.ss")
  (require-contracts)
  (require-mz:class)
  (require-list)
  (require-etc)

  (define-struct pool (value->handle object-count type->count))
  (define-struct handle (pool))
  (define-struct (atom-handle handle) (atom))
  (define-struct (object-handle handle) (index class fields))
  (define-struct (generic-handle handle) (tag weak-box))
  (define-struct (unknown-handle handle) ())
  (define-struct event (time value))

  (define (handle->string handle)
    (cond
     [(atom-handle? handle) (format "~s" (atom-handle-atom handle))]
     [(object-handle? handle) (format "~s" (handle-tag handle))]
     [(generic-handle? handle)
      (let* ([value (handle-value handle)])
        (if value
            (format "~s" value)
            (format "<~s>" (handle-tag handle))))]
     [(unknown-handle? handle)
      (format "<~s>" (handle-tag handle))]))

  (define (handle=? one two)
    (eq? (handle-tag one) (handle-tag two)))

  (define (new-pool)
    (make-pool (make-hash-table 'weak) 0 (make-hash-table)))

  (define (pool-lookup pool value)
    (hash-table-get/fill (pool-value->handle pool) value
                         (lambda () (new-handle pool value))))

  (define (new-handle pool value)
    (cond
     [(atom? value) (new-atom-handle pool value)]
     [(mz:object? value) (new-object-handle pool value)]
     [else (new-generic-handle pool value)]))

  (define (new-atom-handle pool value)
    (make-atom-handle pool value))

  (define (new-object-handle pool object)
    (let*-values ([(class skipped?) (mz:object-info object)]
                  [(index) (+ (pool-object-count pool) 1)])
      (set-pool-object-count! pool index)
      (make-object-handle pool index (or class mz:object%) (make-hash-table))))

  (define (new-generic-handle pool value)
    (make-generic-handle pool (make-tag pool value) (make-weak-box value)))

  (define (handle-tag handle)
    (cond
     [(unknown-handle? handle) 'unknown]
     [(atom-handle? handle) (format "~s" (atom-handle-atom handle))]
     [(generic-handle? handle) (generic-handle-tag handle)]
     [(object-handle? handle)
      (string->symbol
       (format "Obj~s" (object-handle-index handle)))]))

  (define (handle-value handle)
    (cond
     [(unknown-handle? handle) #f]
     [(atom-handle? handle) (atom-handle-atom handle)]
     [(object-handle? handle) #f]
     [(generic-handle? handle)
      (weak-box-value (generic-handle-weak-box handle))]))

  (define (make-tag pool value)
    (let* ([type->count (pool-type->count pool)]
           [type-symbol (struct->type-symbol value)]
           [type-count (hash-table-increment type->count type-symbol)]
           [tag-string (format "~a~a" type-symbol type-count)])
      (string->symbol tag-string)))

  (define struct-regexp (regexp "^struct:"))

  (define (struct->type-symbol struct)
    (let* ([struct-symbol (vector-ref (struct->vector struct) 0)]
           [struct-string (symbol->string struct-symbol)]
           [type-string (regexp-replace struct-regexp struct-string "")]
           [type-symbol (string->symbol type-string)])
      type-symbol))

  (define (hash-table-get/fill table key thunk)
    (hash-table-get
     table key
     (lambda ()
       (let* ([value (thunk)])
         (hash-table-put! table key value)
         value))))

  (define (hash-table-increment table key)
    (let* ([count (+ 1 (hash-table-get/fill table key (lambda () 0)))])
      (hash-table-put! table key count)
      count))

  (define (object-class handle)
    (object-handle-class handle))
  
  (define (object-fields handle)
    (let* ([table (object-handle-fields handle)]
           [names null])
      (hash-table-for-each
       table
       (lambda (name signal)
         (set! names (cons name names))))
      (mergesort
       names
       (lambda (one two)
         (string<? (symbol->string one) (symbol->string two))))))
  
  (define (object-get-field obj-handle name time)
    (let* ([table (object-handle-fields obj-handle)]
           [signal (hash-table-get table name (lambda () null))])
      (recur loop ([events signal])
        (if (null? events)
            (make-unknown-handle (handle-pool obj-handle))
            (let* ([event (car events)])
              (if (<= (event-time event) time)
                  (event-value event)
                  (loop (cdr events))))))))
  
  (define (object-set-field obj-handle name time handle)
    (let* ([table (object-handle-fields obj-handle)]
           [signal (hash-table-get table name (lambda () null))]
           [event (make-event time handle)])
      (hash-table-put!
       table name
       (recur loop ([events signal])
         (if (null? events)
             (list (make-event time handle))
             (let* ([event* (car events)]
                    [time* (event-time event*)])
               (cond
                [(< time* time) (cons event events)]
                [(= time* time) (cons event (cdr events))]
                [(> time* time) (cons event* (loop (cdr events)))])))))))

  (provide/contract
   [pool? predicate/c]
   [handle? predicate/c]
   [atom-handle? predicate/c]
   [object-handle? predicate/c]
   [generic-handle? predicate/c]
   [unknown-handle? predicate/c]
   [handle=? (handle? handle? . -> . boolean?)]
   [handle->string (handle? . -> . string?)]
   [rename new-pool make-pool (-> pool?)]
   [pool-lookup (pool? any/c . -> . handle?)]
   [handle-pool (handle? . -> . pool?)]
   [handle-tag (handle? . -> . symbol?)]
   [handle-value (handle? . -> . any/c)]
   [object-class (object-handle? . -> . mz:class?)]
   [object-fields (object-handle? . -> . (listof symbol?))]
   [object-get-field (object-handle? symbol? timestamp/c . -> . handle?)]
   [object-set-field (object-handle? symbol? timestamp/c handle? . -> . void?)]
   ))