(module view mzscheme
(require "buffer.ss"
"pool.ss"
"action.ss"
"action-util.ss"
"require.ss")
(require-contracts)
(require-list)
(require-etc)
(define-struct view
(subscription
buffer
predicate
action-list object-list
action-vector object-vector
action->index object->index
object->origin))
(define (new-view buffer predicate)
(make-view (buffer-subscribe buffer) buffer predicate
(list) (list)
(vector) (vector)
(make-hash-table) (make-hash-table)
(make-hash-table)))
(define (view-update view)
(let* ([subscription (view-subscription view)]
[predicate (view-predicate view)]
[action-list (view-action-list view)]
[object-list (view-object-list view)]
[object->origin (view-object->origin view)]
[new-actions (buffer-update subscription)]
[view-actions (filter predicate new-actions)])
(update-object-origins object->origin new-actions)
(let* ([action-list (srfi1:append-reverse view-actions action-list)]
[object-list
(insert-objects view-actions object-list object->origin)]
[action-vector (list->vector (reverse action-list))]
[object-vector (list->vector (reverse object-list))]
[action->index (vector-invert action-vector)]
[object->index (vector-invert object-vector)])
(set-view-action-list! view action-list)
(set-view-object-list! view object-list)
(set-view-action-vector! view action-vector)
(set-view-object-vector! view object-vector)
(set-view-action->index! view action->index)
(set-view-object->index! view object->index))))
(define (update-object-origins table actions)
(for-each
(lambda (action)
(when (new? action)
(hash-table-put! table
(new-object action)
(+ (action-timestamp action) 1))))
actions))
(define (insert-objects actions objects origin-table)
(define (insert-object object objects)
(let* ([origin (hash-table-get origin-table object origin-failure)])
(recur loop ([objects objects])
(if (null? objects)
(list object)
(let* ([object* (car objects)]
[origin*
(hash-table-get origin-table object* origin-failure)])
(cond
[(< origin* origin) (cons object objects)]
[(= origin* origin) objects]
[(> origin* origin) (cons object* (loop (cdr objects)))]))))))
(define (insert-object/f object/f objects)
(if object/f (insert-object object/f objects) objects))
(define (insert-action-objects action objects)
(insert-object/f
(action-source action)
(insert-object/f
(action-target action)
objects)))
(foldl insert-action-objects objects actions))
(define (vector-invert vec)
(let* ([table (make-hash-table)])
(recur loop ([index (- (vector-length vec) 1)])
(when (>= index 0)
(hash-table-put! table (vector-ref vec index) index)
(loop (- index 1))))
table))
(define (view-count-actions view)
(vector-length (view-action-vector view)))
(define (view-count-objects view)
(vector-length (view-object-vector view)))
(define (view-get-action view index)
(vector-ref (view-action-vector view) index))
(define (view-get-object view index)
(vector-ref (view-object-vector view) index))
(define (view-action-index view action)
(hash-table-get (view-action->index view) action action-failure))
(define (view-object-index view object)
(hash-table-get (view-object->index view) object object-failure))
(define (view-object-origin view object)
(hash-table-get (view-object->origin view) object origin-failure))
(define (origin-failure)
(error 'view-update "found object without origin"))
(define (action-failure)
(error 'view-action-index "no such action"))
(define (object-failure)
(error 'view-object-index "no such object"))
(provide/contract
[view? predicate/c]
[rename new-view make-view (buffer? (action? . -> . any/c) . -> . view?)]
[view-buffer (view? . -> . buffer?)]
[view-update (view? . -> . void?)]
[view-count-actions (view? . -> . natural-number/c)]
[view-count-objects (view? . -> . natural-number/c)]
[view-get-action (view? natural-number/c . -> . action?)]
[view-get-object (view? natural-number/c . -> . object-handle?)]
[view-action-index (view? action? . -> . natural-number/c)]
[view-object-index (view? object-handle? . -> . natural-number/c)]
[view-object-origin (view? object-handle? . -> . natural-number/c)]))