model/view.ss
(module view mzscheme

  (require "buffer.ss"
           "pool.ss"
           "action.ss"
           "action-util.ss"
           "require.ss")
  (require-contracts)
  (require-list)
  (require-etc)

  ;; A View is (make-view Buffer (Action -> Boolean)
  ;;                      (Listof Action) (Listof ObjectHandle)
  ;;                      (Vecof Action) (Vecof ObjectHandle)
  ;;                      (HashTableof Action NaturalNumber)
  ;;                      (HashTableof ObjectHandle NaturalNumber)
  ;;                      (HashTableof ObjectHandle NaturalNumber))
  ;; buffer represents the underlying sequence trace
  ;; predicate represents the choice of viewed actions
  ;; action-list represents the included actions so far in reverse order
  ;; object-list represents the included objects so far in reverse order
  ;; action-vector represents the included actions so far in normal order
  ;; object-vector represents the included actions so far in normal order
  ;; object->origin maps object handles to their origin timestamp
  (define-struct view
    (subscription
     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) 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-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)]))