(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?)] ))